perm filename TOTAL[SAI,TES] blob
sn#049734 filedate 1973-06-18 generic text, type T, neo UTF8
00100 COMMENT ⊗ VALID 00050 PAGES VERSION 16-2(22)
00200 RECORD PAGE DESCRIPTION
00300 00001 00001
00400 00006 00002 HISTORY
00500 00009 00003 DATA for Total (Low-level Code Production) Routines
00600 00012 00004 Description of Total Routines
00700 00022 00005 CONV, PRE, POST -- Type-Conversion routines
00800 00026 00006
00900 00030 00007
01000 00035 00008
01100 00036 00009 PUT
01200 00039 00010 ACCESS,GETSDR,GETDR,DISBLK,ZOTDIS--last four only for dis
01300 00047 00011 GET
01400 00050 00012
01500 00053 00013
01600 00056 00014
01700 00060 00015 STACK -- Issue Instrs. to Stack Anything on Approp. Stack
01800 00063 00016 MARK, MARKINT, MARKME -- Mark Semblk with Correct Temp Semantics
01900 00066 00017 INCOR -- Issue Code to Clear this Entity from ACs
02000 00067 00018 REMOPs, CLEARs -- Remove Temps, ACs, from Use
02100 00071 00019 STROP -- Bit-Driven String Operation Code Generator
02200 00076 00020 GETTEM, etc. -- Temp Semblk Allocators
02300 00079 00021 GETAC, GETAN0 -- AC Allocators
02400 00085 00022 AC Store routines -- BOLSTO, FORSTO, STORIX, GOSTO, STORZ
02500 00090 00023 STORA -- main AC-storing subr. -- called by above
02600 00095 00024 EMITER -- Descriptions of Routine and Control Bits
02700 00098 00025 EMITER Routine
02800 00102 00026
02900 00107 00027 SUBI TEMP,1 FIX IT
03000 00113 00028
03100 00116 00029 Qstack Routines -- BPUSH, etc.
03200 00120 00030
03300 00123 00031
03400 00126 00032 PWR2
03500 00127 00033 GBOUT Description, Loader Block Format Description
03600 00130 00034 Control Variables for Loader Block Output
03700 00133 00035 Loader Output Blocks-- Entry, Program Name, Initial Stuff
03800 00137 00036 Code, Boolean Code, Fixups, Links
03900 00141 00037 Space Allocation Block
04000 00144 00038 Request Blocks -- RELfile, Libraries
04100 00146 00039 Ending Code, Symbols -- END Block
04200 00150 00040 RELINI -- Loader Block Initialization
04300 00151 00041 GBOUT Routine
04400 00153 00042 CPUSH -- SLS only
04500 00157 00043 CODOUT Routine -- Output Code or Data
04600 00161 00044
04700 00163 00045 FBOUT, etc. -- Output Fixups
04800 00167 00046 SCOUT, etc. -- Output Symbols
04900 00170 00047
05000 00174 00048 LNKOUT -- Output Linkage Block
05100 00176 00049 PRGOUT, FILSCN -- Output Request Blocks, Scan for Source_file Rqst
05200 00180 00050 RAD50, RAD52 -- Radix-50 Functions for Scout Routines
05300 00184 ENDMK
05400 ⊗;
00100 COMMENT ⊗HISTORY
00200 AUTHOR,REASON
00300 021 202000000026 ⊗;
00400
00500
00600 COMMENT ⊗
00700 VERSION 16-2(22) 12-13-72 BY JRL BUG #KS# ADD LOADVR SWITCH
00800 VERSION 16-2(21) 12-13-72
00900 VERSION 16-2(20) 11-30-72 BY JRL MAKE GET HONEST FOR ? ITEMVARS
01000 VERSION 16-2(19) 11-30-72 BY JRL BUG #KQ# IGNORE FIXARRS IN STORA
01100 VERSION 16-2(18) 11-21-72 BY RHT BUG #KH# DEL FORMFX STUFF FROM SIMPROC FORMALS
01200 VERSION 16-2(17) 10-17-72 BY JRL BUG #JR# STRING ITEMVARS NOT STRING
01300 VERSION 16-2(16) 8-29-72 BY KVL ADD CKECK FOR UNTYPED IN PRE
01400 VERSION 16-2(15) 7-17-72 BY RHT BUG #IO# EVAR MESSED UP BY INDEXED STRING TEMP
01500 VERSION 16-2(14) 7-8-72 BY RHT BUG ##I#L# GET ACCESS TO A VARIABLE IN PRE BEFORE INSISTING
01600 VERSION 16-2(13) 6-30-72 BY DCS BUG #IA# PROTECT PTRAC AC OVER FIX, FLOAT, STRING→INTEGER
01700 VERSION 16-2(12) 6-25-72 BY DCS BUG #HX# PARAMETERIZE LIBRARY NAMES (OTHER THINGS)
01800 VERSION 16-2(11) 6-20-72 BY DCS BUG #HU# BETTER TTY PRINTOUT
01900 VERSION 16-2(10) 6-14-72 BY JRL BUG #HS# AN ITEMVAR IS NOT ITS DATUM(MARK).
02000 VERSION 16-2(9) 5-13-72 BY DCS BUG #HF# MAKE GETAC MUCH MORE HONEST
02100 VERSION 15-2(8) 3-25-72 BY DCS BAD ARRAY ADDRESS PROBLEM
02200 VERSION 15-2(7) 3-10-72 BY DCS REPLACE RING, ULINK MACROS WITH ROUTINES
02300 VERSION 15-2(6) 2-9-72 BY DCS BUG #GQ# MAKE ! ≡ _ IN RADIX50
02400 VERSION 15-2(5) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF
02500 VERSION 15-2(4) 2-1-72 BY DCS ISSUE %ALLOC SPACE REQUESTS IN NEW WAY (SEE GOGOL FOR FORMAT)
02600 VERSION 15-2(3) 1-10-72 BY DCS BUG #FP# FIX A NEGAT BUG
02700 VERSION 15-2(2) 1-7-72 BY DCS BUG #FY# Fix Strvar←INAC-Intvar bookkeeping problem
02800 VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
02900
03000 ⊗;
00100 COMMENT ⊗DATA for Total (Low-level Code Production) Routines⊗
00200 LSTON (TOTAL)
00300
00400 SUBTTL WIZARD'S DEN -- Generator Called Routines.
00500 BEGIN TOTAL
00600
00700 ZERODATA (TOTAL ROUTINE VARIABLES)
00800
00900 ;ACKPNT -- next AC # GETAC should try -- used to distribute
01000 ; AC usages among the ACs -- used by GETAC only
01100 ↓ACKPNT: 0
01200
01300 COMMENT ⊗
01400 FORMFX -- QSTACK descriptor for formal fixups. Until a recursive
01500 Procedure has been completely compiled, it is not known how
01600 many local strings and non-strings will be saved in the runtime
01700 stacks between the stack tops and the formal parameters. Therefore
01800 as instructions accessing parameters are issued, the address
01900 field displacements (assuming 0 locals) are saved, along with
02000 the addresses where they are issued, in the FORMFX stack.
02100 The left half of each entry is the address of the instruction--
02200 the right half is the desired relative displacement (high-order
02300 bit specifies String stack or System stack). After the procedure
02400 is compiled, these entries are QPOPed off and used, along with
02500 the ALOCALS, SLOCALS counts (see PROCED variables) to issue
02600 fixups for these instructions. This Qstack is not used
02700 for non-recursive Procedures
02800 ⊗
02900 ↑↑FORMFX: 0
03000
03100 ↓POSSIB: 0 ;TEMP USED BY GETAC WHEN GETTING 2
03200
03300 ;TEMPNO -- each temp Semblk allocated is assigned a unique
03400 ; number, by incrementing TEMPNO -- a temp Semblk may
03500 ; be used several times in the same procedure. See GETTEM
03600 ; for description of the mysteries of temps.
03700 ↓TEMPNO: 0
03800
03900 ENDDATA
00100 COMMENT ⊗Description of Total Routines⊗
00200
00300 DSCR CONV,ACCESS,GET,PUT,STACK,MARK
00400 DES This is the generalized move code. (i.e. called by macro GENMOV).
00500 It consists of several routines which are called in a uniform
00600 fashion. This fashion stipulates that "directive" bits be passed
00700 in the right half of FF which specify modifiers on the operation
00800 of the routine called. Each routine is preceded by a standard
00900 preamble (PRE) and followed by a standard epilog (POST).
01000
01100 Some of the directive bits control PRE and POST. They are:
01200
01300 PAR
01400 PRE:
01500 1. If the GETD bit is on, we do a GETAD first (i.e. use PNT
01600 as the pointer to a symbol table entry, and fill TBITS
01700 and SBITS. This is useful since many of the GENMOV routines
01800 require that TBITS and SBITS be set up.
01900 2. If the PROTECT bit is set, then register D is assumed to have
02000 an accumulator number in it. That accumulator table entry
02100 is "protected". I.e. calls on GETAC and STORA will not affect
02200 the status of anything marked in that accumulator.
02300 3. If the EXCHIN bit is set, we do an EXCHOP.
02400 4. If the INSIST bit is on, type conversions are performed.
02500 These conversions convert from the type specified in the
02600 TBITS word to the type specified in register B (bits
02700 passed to the INSISTer).
02800 5. If the ARITH bit is on, we make sure that the type is
02900 an arithmetic type, performing conversions if necessary.
03000
03100
03200 POST:
03300 1. Put the current contents of the ac's TBITS and SBITS
03400 down in the symbol table entry pointed to by PNT
03500 2. If the REM bit is set, do a REMOP on the thing in PNT
03600 3. If the BITS2 bit is set, we execute MOVE SBITS2,$SBITS(PNT2)
03700 This is useful when an operation on one argument of a binary
03800 op. may change the semantics of another.
03900 4. If the UNPROTECT bit is set, then register D is assumed to
04000 contain an ac number. The ac table entry is unprotected.
04100 5. If the EXCHOUT bit is set, we do an EXCHOP.
04200
04300 NOW FOR A DESCRIPTION OF THE ROUTINES WHICH ACTUALLY USE PRE AND POST:
04400
04500 CONV:
04600 This is really a no-op. It is here for the purposes of calling
04700 the type-conversion routines in PRE, and for the purpose of
04800 making sure that an argument is positive if in an accumulator
04900 (e.g. if we had CVF(-(A+B)), then the result would be in an
05000 accumulator in negated fashion. We now want to push it onto the
05100 stack for the call on CVF. We want to make sure it is REAL and
05200 positive. We use the POSIT bit: GENMOV (CONV,INSIST!POSIT,REAL)
05300
05400
05500 PUT
05600 This issues a store of accumulator mentioned in register D
05700 into the thing described in TBITS, SBITS, PNT. The accumulator
05800 table is updated to reflect this store (i.e. the thing talked about
05900 by PNT is marked as "inac").
06000
06100 If the PNT entry is a string, then D is assumed to be an ac.
06200 into which a HRROI was done, or the SP stack. At any rate, two
06300 POP's are emitted.
06400
06500 ACCESS:
06600 This routine makes sure that we can have access to the entry
06700 mentioned in PNT. That is, if the thing is indexed (result of
06800 an array calculation) and if it requires that some index accumulator
06900 be loaded with a good number, then the load will happen, so
07000 that an effective address can be generated which points at
07100 the thing talked about by PNT.
07200
07300 GET:
07400 This is the generalized "get this entity in an ac" routine.
07500 It makes many checks (i.e. is it already in an ac?) and
07600 finally returns in register D the number of the ac which
07700 has been loaded, and returns in SBITS the updated semantics
07800 information that now reflects the loaded state.
07900 (By the way, to "get" a string means to do HRROI ac,second word
08000 of string.. This is so that POP's can be done later). There
08100 are many modifier bits to this routine:
08200
08300 DBL -- make sure that the ac following the one loaded
08400 is free (for a double ac operation such as IDIV)
08500 INDX -- make sure entity is loaded in an AC which can be
08600 used for indexing (i.e. not 0 or 1. The reason
08700 for including 1 in this is a bit vague -- since
08800 runtime routines often return results in 1, we
08900 try to avoid its use for things thay may have
09000 to be stored as temps).
09100 SPAC -- load this into a special accumulator. That accumulator
09200 number is passed in D.
09300 ADDR -- load the address of this entity, not the value.
09400 POSIT -- make sure the entity is in the ac in positive form.
09500 NEGAT -- make sure in negative form.
09600 NONSTD -- if indxed temp, do not remop it as someone wants
09700 to use it again. (see SWPR for instance). The
09800 problem is not so much remopping, but that GET
09900 likes to make the semantic entries as "inac" on
10000 exit. This fouls up any index calculations that
10100 may have been stored in the PNT entity.
10200 MRK -- when done with the GET, call MARK (see below).
10300
10400 STACK:
10500 The entity mentioned in PNT is stacked on an appropriate
10600 stack. Strings (except arrays) are stacked on the SP
10700 stack, all others on the P stack. ADEPTH or SDEPTH is
10800 updated.
10900
11000 MARK:
11100 This uses the bits in TBITS and SBITS, and the ac number
11200 in D as prototypes for making up a temp descriptor, and
11300 marking the ac full with that temp. Return is a valid
11400 temp descriptor in PNT. If STRING is on in TBITS,
11500 a stacked-string descriptor will be generated
11600 (and of course, no accumulator will be marked).
11700 WARNING ***** MARK masks off some bits in SBITS and
11800 TBITS. PTRAC,CORTMP,INDXED,FIXARR are turned off in SBITS
11900 and the only bits honored by TBITS are:
12000 LPARRAY,SET,ITEM,ITMVAR,INTEGR,FLOTNG,STRING
12100
12200 SID
12300 ACCUMULATORS:
12400 FF -- RIGHT HALF SAVED.
12500 A --THIS MAY BE CHANGED
12600 B --SAVED, I BELIEVE.
12700 C --SAVED, I BELIEVE.
12800 D --OCCASIONALLY FILLED UP (E.G. GET,ACCESS)
12900 TBITS -- THESE ARE THE SEMANTIC BITS -- THEY MAY BE CHANGED.
13000 SBITS -- "
13100 PNT -- " (IN CASE OF MARK OR CONVERSIONS)
13200 LPSA CLOBBERED
13300 USER CLOBBERED
13400 TEMP CLOBBERED
13500 SP --SAVED
13600 SBITS2 --SAVED (modulo what is done in PRE).
13700 TBITS2 --SAVED
13800 PNT2 --SAVED
13900
14000 SEE GENMOV MACRO
14100 ⊗;
00100 COMMENT ⊗CONV, PRE, POST -- Type-Conversion routines⊗
00200
00300 MASK←← 0+LPARRAY+SET+LSTBIT+ITEM+ITMVAR+INTEGR+FLOTNG+STRING
00400 ;GENMOVE KNOWS ABOUT THESE TYPES
00500
00600 ;THIS IS THE PREAMBLE FOR ALL OF THE ROUTINES WHICH
00700 ;USE DIRECTIVE BITS TO SPECIFY COERCIONS, EXCHOPS, ETC.
00800
00900 PREMASK ←← GETD!EXCHIN!INSIST!ARITH!PROTECT
01000
01100
01200 ↑↑CONV: TRNE FF,PREMASK
01300 PUSHJ P,PRE ;DO EVERYTHING HERE.
01400 TLNE SBITS,NEGAT ;IF NOT NEGAT OR
01500 TRNN FF,POSIT ;NOT NEED THINGS POSITIVE?
01600 JRST POST ;ALL DONE.
01700 JRST GETOPE ;DO THE GET.
01800
01900
02000
02100 PRE: TRNE FF,GETD ;DO A GETAD?
02200 PUSHJ P,GETAD ;YES
02300 TRNE FF,EXCHIN!PROTECT ;EXCHOP ON WAY IN?
02400 JRST [TRNE FF,PROTECT
02500 HRROS ACKTAB(D)
02600 TRNN FF,EXCHIN
02700 JRST .+1
02800 EXCHOP
02900 JRST .+1]
03000 TRNN FF,INSIST!ARITH ;ANY COERCIONS TO DO?
03100 POPJ P, ;NO -- ALL DONE.
03200 PUSHJ P,QTYPCK
03300 ;CHECK FOR UNTYPED AND TYPE IF NEC. (SEE ERRORS)
03400 ;#IL# 7-8-72 RHT ↓ GET ACCESS BEFORE YOU CONVERT
03500 PUSHJ P,ACCOP ;GET ACCESS -- YOU MAY NEED IT
03600 TRNE FF,ARITH ;WANT TO BE SURE OF ARITH ARG?
03700 JRST AGET ;YES
03800 LEP <
03900 LEPPRE: TRNN TBITS,ITEM!ITMVAR ;IF EITHER HAS ITEM BITS ON.
04000 TRNE B,ITEM!ITMVAR ;ALL THESE ARE GOOD GUYS.
04100 JRST [ ;.... ;KEEP GOING.
04200 TRNE B,ITEM!ITMVAR
04300 TRNN TBITS,ITEM!ITMVAR
04400 ERR <ITEM TYPE MISMATCH >,1
04500 POPJ P,] ;THIS IS ALL THE CHECKING!
04600 TRNE B,SET ;A SET OR LIST DESIRED?
04700 JRST [TRNN TBITS,SET ;IF NOT LIST OR A SET CAN'T BE DONE
04800 ERR <TYPE CAN'T BE CONVERTED TO SET OR LIST>,1
04900 TRNE B,LSTBIT ;IF WANTED LIST CAN RETURN
05000 JRST MAKLST ;MAY HAVE TO COPY LIST.
05100 TRNN TBITS,LSTBIT ;IF WANTED SET AND HAVE SET CAN RETURN
05200 POPJ P,
05300 JRST MAKEST] ;WILL HAVE TO CALL CVSET
05400 >;LEP
05500 MOVE USER,B ;COPY OFF.
05600 MOVE TEMP,TBITS
05700 AND TEMP,[XWD SBSCRP,MASK≠(ITEM!ITMVAR)]
05800 ORCB USER,[XWD SBSCRP,MASK≠(ITEM!ITMVAR)]
05900 TDNN TEMP,USER ;ARE ALL BITS IN B ON IN TBITS?
06000 POPJ P, ;THEY MATCH !!
06100 AGOTH:
06200 PUSH P,FF
06300 TRZ FF,-1≠NONSTD ;IN CASE ANY OTHER ROUTINES CALLED.
06400 PUSH P,D
06500 TRNE B,INTEGR+FLOTNG
06600 JRST RESAR ;INSISTS ON ARITHMETIC TYPE
06700 TRNE B,STRING
06800 JRST RESSTR ;INSISTS ON STRING
06900 ERR <GENMOV MAY BE GENERAL, BUT ...>,1
07000 JRST GEMGO ;GO ON ANYWAY
00100
00200
00300 RESSTR: TRNN TBITS,INTEGR ;INSIST ON INTEGER ARGUMENT.
00400 ERR <STRINGS OF NON-INTEGERS?>
00500 TLNN TBITS,CNST ;CONSTANT?
00600 JRST STR1 ;NO
00700 EXCH SP,STPSAV ;GET A GOOD STACK POINTER.
00800 MOVSS POVTAB+6 ;ENABLE FOR STRING PDLOV
00900 PUSH P,$VAL(PNT)
01000 PUSHJ P,PUTCH ;MAKE A STRING (SLOWLY)
01100 POP SP,PNAME+1
01200 POP SP,PNAME
01300 EXCH SP,STPSAV ;AND RESTORE EVERYONE.
01400 MOVSS POVTAB+6 ;RE-ENABLE FOR PARSE PDLOV
01500 PUSHJ P,STRINS ;INSERT A STRING CONSTANT
01600 ;THIS DOES A GETAD.
01700 JRST GEMGO ;ALL DONE
01800
01900 STR1: ;PREPARE TO STACK THE INTEGER
02000 PUSHJ P,STACK1 ;DO THE STACK.
02100 SOS ADEPTH ;SINCE THE RUNTIM ROUTINES ADJUST.
02200 MOVEI TEMP,2
02300 ADDM TEMP,SDEPTH ;INCREASE DUE TO CALL.
02400 XCALL <PUTCH> ;FUNCTION CALL
02500 MOVEI SBITS,0 ;START WITH CLEAN DYNAMIC SLATE
02600 JRST TGO ;GO MAKE A TEMP.
02700
02800
02900
03000 AGET: TRNE TBITS,INTEGR+FLOTNG ;IS IT ALREADY ARITHMETIC TYPE?
03100 POPJ P, ;YES
03200 PUSH P,FF
03300 TRZ FF,-1≠NONSTD ; SAVE ALL THIS FOR OTHER
03400 PUSH P,D ; EMBEDDED OPERATIONS
03500 MOVEI B,INTEGR ;THIS FOR THE BENEFIT OF ARSTR.
03600 RESAR: TRNE TBITS,STRING ;HERE TO GET ARITHMETIC RESULTS
03700 JRST ARSTR ;CONVERT FROM STRING
03800 TRNE TBITS,INTEGR+FLOTNG
03900 JRST FIXFL
04000 ERR <THE CONVERSION YOU HAVE REQUESTED ...>,1
04100 JRST TGO ;MAKE A TEMP FOR IT ANYWAY...
04200
04300 ARSTR: TLNE TBITS,CNST ;CONSTANT?
04400 JRST STRCNS
04500 ;;#IA# 6-30-72 DCS (3-6) PROTECT PTRAC AC OVER GETAC
04600 HRLI PNT,-1 ;FLAG, ASSUME PROTECTION
04700 HRRZ TEMP,$ACNO(PNT) ;PTRAC AC #, IF ANY
04800 TLNN SBITS,PTRAC ;NEED PROTECTION?
04900 TLZA PNT,-1 ;NO, UNMARK
05000 HRROS ACKTAB(TEMP) ;YES, PROTECT
05100 ;;#IA# (3-6)
05200 PUSH P,B ;SAVE TYPE WORD
05300 PUSHJ P,GETAN0 ;NON-0 AC NUMBER
05400 JUMPGE PNT,.+3 ;NEED TO UNPROTECT?
05500 ;;#IA# 6-30-72 (4-6)
05600 HRRZ TEMP,$ACNO(PNT) ;YES, DO
05700 HRRZS ACKTAB(TEMP) ; IT
05800 ;;#IA# (4-6)
05900 MOVE A,[HRRZ LNWORD] ;CALCULATE LENGTH TO THIS AC
06000 PUSHJ P,STROP ;VIA STROP
06100 HRL B,PCNT ;SAVE PC FOR FIXUP
06200 HRLI C,0
06300 EMIT (<JUMPE USADDR!NORLC>) ;0 IF STRING EMPTY
06400 TLNE SBITS,STTEMP ;NO NEED TO COPY BP IF TEMP STRING
06500 JRST [MOVE A,[ILDB BPWORD]
06600 PUSHJ P,STROP ;SO DO ILDB DIRECTLY
06700 JRST NOCOP] ;AND GET OUT
06800 MOVE A,[MOVE BPWORD] ;GET COPY OF BP
06900 PUSHJ P,STROP ;IN SAME AC
07000 HRL C,D
07100 EMIT (<ILDB USADDR!NORLC>) ;ILDB AC,AC
07200 NOCOP: HRR B,PCNT ;FIXUP WORD
07300 PUSHJ P,FBOUT
07400 MOVEI A,UNDO!REM
07500 PUSHJ P,STROP ;NOW ISSUE SUB IF NECESSARY
07600 PUSHJ P,MARKINT ;MARK INT. RETS RIGHT THING IN PNT
07700 POP P,B
07800 TRNE B,INTEGR ;CONVERT ONLY TO INTEGER?
07900 JRST GEMGO ;YES, OK.
08000 JRST FIXFL ;GO ON FARTHER
00100
00200 STRCNS: HRRZ TEMP,$PNAME(PNT) ;THIS IS THE SAME CODE AS
00300 JUMPE TEMP,.+3 ; SAIL GENERATES TO DO
00400 MOVE TEMP,$PNAME+1(PNT) ; STRING→INTEGER AT
00500 ILDB TEMP,TEMP ; RUNTIME
00600 TRNN B,INTEGR ;DOES HE WANT AN INTEGER CONST
00700 FLOAT TEMP,TEMP ;NO -- ASSUME FLOATING
00800 JRST CONGO ;GO INSERT A CONSTANT.
00900
01000 FIXFL: MOVE USER,[FIX TEMP,TEMP] ;FIX OPERATION?
01100 MOVE TEMP,TBITS ;GET OR OF `SHORT' BITS
01200 OR TEMP,B
01300 TRNE B,INTEGR ;RESULT FIXED?
01400 JRST FIX ;YES
01500 HRLI USER, (<FLOAT TEMP,0>) ;CHANGE TO FLOAT
01600 TLNE TBITS,CNST ;CONSTANT?
01700 JRST FLC
01800 MOVSI A,(<FLOAT>)
01900 TRNN TEMP,SHORT ;SHORT INTEGER BEGIN FLOATED?
02000 JRST UUOGO ;NO, USE UUO
02100 PUSH P,[FSC USADDR!NORLC] ;INSTR TO FLOAT
02200 HRLI C,233 ;ARGUMENT OF FLOAT INSTR
02300 SHRTCV: MOVE TEMP,-2(P) ;FF BITS COMING INTO TOTAL
02400 TRNE TEMP,SPAC ;WAS SPECIFIC AC REQUIRED
02500 TRO FF,SPAC ;YES, RETAIN IT
02600 PUSHJ P,GET ;GET THE THING
02700 POP P,A ;INSTR
02800 JRST JSTEST ;ALREADY KNOW WHAT AC
02900
03000
03100 FIX: TLNE TBITS,CNST ;CONSTANT?
03200 JRST FLC
03300 MOVSI A,(<FIX>) ;CALL FIX
03400 NOEXPO<
03500 TRNN TEMP,SHORT ;CONVERT TO SHORT INTEGER?
03600 JRST UUOGO ;NO
03700 PUSH P,[PDPFIX USADDR!NORLC] ;YES, USE PDP-10 INSTR
03800 HRLI C,233000 ;MAGIC ADDR FIELD FOR PDPFIX INSTR
03900 JRST SHRTCV ;DO SHORT CONVERSION
04000 >;NOEXPO
04100
04200 UUOGO: MOVE TEMP,-1(P) ;DIRECTIVE BITS WORD FROM STACK.
04300 TRNE TEMP,SPAC ;IS HE GOING TO WANT A SPECIAL ONE?
04400 JRST JSTEST ;YES
04500 HRR D,$ACNO(PNT)
04600 ;;#IA# 6-30-72 DCS (5-6) PROTECT PTRAC AC OVER GETAC
04700 HRLI PNT,-1 ;FLAG, ETC., SEE PART (3-6)
04800 TLNN SBITS,PTRAC
04900 TLZA PNT,-1
05000 HRROS ACKTAB(D)
05100 ;;#IA# (5-6)
05200 TLNN SBITS,INAC ;IF NOT IN AN AC, THEN GET ONE.
05300 PUSHJ P,GETAC
05400 ;;#IA# 6-30-72 (6-6)
05500 JUMPGE PNT,.+3
05600 HRRZ TEMP,$ACNO(PNT)
05700 HRRZS ACKTAB(TEMP)
05800 ;;#IA# (6-6)
05900 GOTACB:
06000 JSTEST:
06100 DPB D,[POINT 4,A,12] ; STORE AC NUMBER IN INSTRUCTION.
06200 PUSHJ P,EMITER
06300 HRRZ TEMP,FF ;ORIGINAL FF
06400 TRNE TEMP,NONSTD ;IF NON-STANDARD (SEE SWAP OPER),
06500 JRST [POP P,(P) ; DON'T REMOP OR MARK
06600 JRST GEMGO1] ;BUT RETAIN THE AC USED
06700 PUSHJ P,REMOP ;REMOP THE OPERAND.
06800 TGO: HRRZ TBITS,B ;MAKE TBITS CONFORM TO THE DESIRED TYPE
06900 ANDI TBITS,MASK ;MAKE RESULT LOOK LIKE THE REQUESTS
07000 TLZ SBITS,-1≠NEGAT ;CLEAR AWAY THE CHAFF
07100 PUSHJ P,MARK1 ;GO DO A MARK.
07200 JRST GEMGO
07300
07400 FLC: MOVE TEMP,$VAL(PNT) ;HERE FOR A CONSTANT.
07500 XCT USER ;DO THE CONVERSION
07600 CONGO: MOVEM TEMP,SCNVAL ;SET UP FOR SYMBOL TABLE INSERTION
07700 HRRZ TBITS,B ;COME HERE TO INSERT A CONSTANT.
07800 ANDI TBITS,MASK
07900 TLO TBITS,CNST
08000 MOVEM TBITS,BITS ;FOR CONINS
08100 PUSHJ P,REMOP ;ALWAYS REMOVE THE OLD GUY
08200 PUSHJ P,CONINS
08300 GEMGO: POP P,D
08400 GEMGO1: POP P,FF ;AT LAST DO THE POP AND
08500 POPJ P, ;ALL DONE -- FULL SPEED AHEAD.
00100
00200 ; NOW FOR THE POSTAMBLE (WE WILL AMBLE THROUGH THE COMPILATION).
00300
00400
00500 POST: MOVEM SBITS,$SBITS(PNT) ;PUT DOWN SEMANTICS WORDS.
00600 MOVEM TBITS,$TBITS(PNT)
00700 TRNN FF,EXCHOUT!BITS2!REM!UNPROTECT ;THESE ARE THINGS TO DO.
00800 POPJ P, ;ALL DONE.
00900 TRNE FF,REM ;REMOP THE THING?
01000 JRST [PUSHJ P,REMOP ;YES
01100 MOVE SBITS,$SBITS(PNT)
01200 JRST .+1]
01300 TRNE FF,BITS2 ;UPDATE SBITS2?
01400 MOVE SBITS2,$SBITS2(PNT2) ;DONE.
01500 TRNE FF,UNPROTECT
01600 HRRZS ACKTAB(D)
01700 TRNN FF,EXCHOUT ;EXCHANGE ON WAY OUT?
01800 POPJ P, ;NO --DONE.
01900 EXCHOP
02000 POPJ P,
00100 COMMENT ⊗PUT⊗
00200
00300 ↑↑PUT: TRNE FF,PREMASK ;ANY PREAMBLE TO BE DONE
00400 PUSHJ P,PRE ;YES -- DO IT.
00500 PUSH P,FF ;HERE TO STORE AN ACCUMULATOR INTO
00600 TLNE SBITS,INDXED ;A DESCRIPTOR
00700 PUSHJ P,ACCOP ;GET ACCESS TO THE TARGET.
00800 TRNE TBITS,STRING ;IF NOT A STRING
00900 TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;OR NOT REALLY A STRING,THEN
01000 JRST APUT ;USE A MOVEM OR THE LIKE.
01100
01200 MOVE A,[POP BPWORD!LNWORD!SBOP!BPFIRST]
01300 PUSHJ P,STROP ;USE THE STRING OPERATION TO PUT OUT POPS.
01400 CAIE D,RSP ;IF IT WAS NOT THE STACK, THEN
01500 PUSHJ P,CLEARA ;CLEAR OUT THIS ACCUMULATOR ENTRY.
01600 ;IT WAS CHANGED WHEN THE POPS WERE DONE ANYWAY.
01700 JRST PUTFIN ;ALL DONE. MY THAT WAS SIMPLE.
01800
01900 APUT: PUSHJ P,CLEARA ;CLEAR OUT THE DESTINATION ACCUMULATOR.
02000 TLNE SBITS,INAC ;IF THE DESTINATION OF THE STORE IS ALREADY
02100 PUSHJ P,CLEAR ;IN AN AC, THEN CLEAR IT OUT.
02200 HRLZI A,(<MOVEM>) ;THE ORDINARY STORE INSTRUCTION.
02300 TLNE SBITS,NEGAT ; BUT IF NEGATED, USE THE OTHER
02400 HRLI A,(<MOVNM>)
02500 PUSHJ P,EMITER ;AND PUT OUT THE INSTRUCTION.
02600
02700 TLNE SBITS,INDXED ;WE DO NOT WANT TO MARK *********
02800 JRST PUTFN1 ;GO AWAY.
02900
03000 HRRM D,$ACNO(PNT) ;AND THE AC IT IS IN
03100 HRRM PNT,ACKTAB(D) ;IN TWO PLACES.
03200 ;THIS UNPROTECTS THIS ACCUMULATOR.
03300 TLOA SBITS,INAC ;AND NOW MARK THE DESCRIPTOR BITS
03400
03500 PUTFN1: TLZ SBITS,NEGAT ;SUBSCRIPTED, NEGAT GETS IN WAY (BELIEVE!)
03600 PUTFIN: POP P,FF ;ALL DONE
03700 JRST POST ;AND FINISH OUT.
00100 COMMENT ⊗ACCESS,GETSDR,GETDR,DISBLK,ZOTDIS--last four only for dis
00200
00300 Call ACCOP when you need to reference a thing and don't know whether you
00400 can get at it in a single instruction (i.e. an indexed thing).
00500 GENMOV(ACCESS) will cause ACCOP to be called for you.
00600 People like GET and STACKOP do it automatically.
00700 ⊗
00800
00900 ↑↑ACCESS: TRNE FF,PREMASK
01000 PUSHJ P,PRE
01100 PUSHJ P,ACCOP
01200 JRST POST
01300
01400 NODIS <
01500 ACCOP: TLNN SBITS,INDXED ;ONLY INTERESTED IN INDEXED VBLS
01600 POPJ P,
01700 >;NODIS
01800 DIS <
01900 ACCOP: TDNN SBITS,[XWD INDXED,DLFLDM]; ONLY CARE IF INDEXED OR NEED A DISPLY
02000 POPJ P,
02100 TLNE SBITS,INAC!PTRAC ;IF IN AN AC WE CAN ACCESS IT
02200 POPJ P,
02300 TRNN SBITS,DLFLDM ;IF DISPLAY LEV=0 ONLY CARE ABOUT INDEXED
02400 JRST INXSTF ;NO WORRY ABOUT THE DIAPLAY
02500 LDB TEMP,[LEVPOINT<SBITS>] ;PICK UP DISPLY LEV
02600 TRNE TBITS,STRING ;IS ITT A STRING
02700 JRST [
02800 ;; #JR# BY JRL 10-17-72 ITEMVARS,ARRAYS DON'T USE STRING STACK
02900 TDNN TBITS,[REFRNC!SBSCRP,,ITEM!ITMVAR];THESE THINGS DON'T USE
03000 TLNE SBITS,INDXED ;INDEXED? ;STRING STACK
03100 JRST .+1
03200 ;; #JR#
03300 JRST GETSDR ;GET STRING DR
03400 ]
03500 PUSHJ P,GETDR ;GET A DISPLAY REG LOADED
03600 TRNN SBITS,INDXED ;INDEXED TOO?
03700 POPJ P, ;NO
03800 INXSTF:
03900 >;DIS
04000 ;;#JR#
04100 TRNN TBITS,ITEM!ITMVAR
04200 TRNN TBITS,STRING ;ALWAYS NEED STRING GUYS
04300 JRST .+2
04400 ;;#JR#
04500 JRST ACMOP
04600 HRRZ TEMP,$VAL(PNT) ; ONLY NEED IT IF NON-ZERO
04700 JUMPE TEMP,CPOPJ ; DISPLACEMENT
04800
04900 ACMOP: TLNE SBITS,PTRAC ;IS IT ALREADY ACCEPTABLE (IN AC)?
05000 POPJ P, ; YES, WHY HAVE WE WORRIED?
05100
05200 PUSH P,D ;HAVE TO SAVE CURRENT AC
05300 PUSH P,A
05400 PUSH P,FF
05500 HRRI FF,INDX ;SO THAT NOTHING NONSTD WILL HAPPEN.
05600 MOVE A,[XWD 40!2!1,ADDR] ;SET NECESSARY BITS
05700 ;(SPECIAL BIT, MOVE, GET AC, USE INDXBLE AC, GET ADDR)
05800 PUSHJ P,GETWD
05900 POP P,FF
06000 POP P,A
06100 POP P,D
06200 POPJ P,
06300
06400 DIS <
06500
06600 COMMENT⊗
06700 DSCR GETSDR,GETDR
06800 DES ROUTINES TO LOAD UP STRING (ARITHMETIC) DISPLAYS
06900 LOADS UP LPSA WITH THE AC NO TO USE & FIXES UP ACTAB,DISTAB,&DISLST
07000 PARM TEMP=LEVEL DESIRED
07100 SID MANGLE TEMP,LPSA
07200 ⊗
07300
07400
07500 ↑↑GETSDR:
07600 HLRZ LPSA,DISTAB(TEMP) ;DO WE HAVE IT ALREADY
07700 CAIE LPSA,0 ;TEST
07800 POPJ P, ;YES
07900 PUSHJ P,GETDR ;GET THE P-DISPLY
08000 PUSH P,FF ;WHAT A PITY WE MIGHT HAVE JUST POPPED
08100 PUSH P,A ;BUT THIS IS QUICKER IN THE LONG
08200 PUSH P,B ;RUN THAN MESSING WITH FLAGS
08300 PUSH P,C ;
08400 PUSH P,D
08500 TRZ FF,DBL ;ONLY ONE AC
08600 HRL D,LPSA ;USE P-DR AS INDEX
08700 MOVE B,TEMP ;WE WILL NEED THIS
08800 HRLI C,2 ;DISPL OF 2
08900 PUSHJ P,GETAN0 ;GET AN AC FOR DISPLY
09000 EMIT (<MOVE ,USX!USADDR!NORLC>) ;LOAD THE DR
09100 HRLM D,DISTAB(B) ;ENTER INTO DISPLAY TABLE
09200 PUSHJ P,DISBLK ;SET UP MOST OF BLOCK
09300 MOVEI TEMP,STRING ;
09400 HRRZM TEMP,$TBITS(LPSA) ;MAKE TYPE RIGHT
09500 MOVSS $VAL(LPSA) ;FIX UP AND MASK
09600 JRST RETSEQ ;GO POP STUFF & RETURN
09700 ↑↑GETDR:
09800 HRRZ LPSA,DISTAB(TEMP) ;PICK UP THE PUTATIVE REGISTER
09900 JUMPN LPSA,CPOPJ ;IF THERE,RETURN
10000 PUSH P,FF
10100 PUSH P,A
10200 PUSH P,B
10300 PUSH P,C
10400 PUSH P,D
10500 PUSH P,TEMP ;GETDR MUST SAVE IT
10600 TRZ FF,DBL ;ONLY ONE AC
10700 HRRZI B,1(TEMP) ;NEXT LEVEL DEEPER
10800
10900 GDR1: HRLZ D,DISTAB(B) ;PICK IT UP
11000 CAIN D,0 ;IS IT LOADED
11100 AOJA B,GDR1 ;NO
11200 HRLI C,1 ;SET TO SELECT STATIC LINK
11300 MOVE A,[<MOVE 0,USX!NORLC!USADDR>]
11400 GDR2: PUSHJ P,GETAN0 ;THIS BETTER LEAVE LH(D) ALONE -- IT DOES
11500 PUSHJ P,EMITER ;UP ONE STATIC LINK
11600 SOS B ;BACK A LEVEL
11700 HRRM D,DISTAB(B) ;SAY WE HAVE IT
11800 PUSHJ P,DISBLK ;TO DO STUFF FOR DISPLAY BLOCK&ACKTAB
11900 CAMN B,(P) ;IS THIS THE ONE WE WANT
12000 JRST GDR4 ;YES
12100 GDR3: HRL D,D ;USE AS INDEX PERHAPS
12200 HRR D,DISTAB-1(B) ;NEXT AC BACK
12300 TRNE D,-1 ;IS IT THERE
12400 SOJA B,GDR3 ;YES
12500 JRST GDR2 ;NO--FETCH IT
12600 GDR4: HRRZ LPSA,D ;AC NO OD DISPLY
12700 POP P,TEMP
12800 RETSEQ: POP P,D
12900 POP P,C
13000 POP P,B
13100 POP P,A
13200 POP P,FF
13300 POPJ P, ;RETURN
13400
13500 COMMENT ⊗
13600 DSCR DISBLK
13700 DES THIS PROCEDURE SETS UP DISPLAY SEMBLK STUFF & UPDATES ACKTAB
13800 IT SETS LPSA TO POINT ATE THE NEW SEMBLK
13900 THE BLOCK IS SET UP FOR A LPSA TYPE SEMBLK
14000 PARM B = DISPLAY LEBEL
14100 D= ACNO OF DISPLAY REG
14200 ⊗
14300 ↑↑DISBLK:
14400 GETBLK ;GET A BLOCK
14500 HRRM D,$ACNO(LPSA) ;SAVE AC NO
14600 HRRM B,$ADR(LPSA) ;LEVEL GOES HERE
14700 SETOM TEMP
14800 HRLZM TEMP,$VAL(LPSA) ;SETS UP ANDING MASK
14900 MOVE TEMP,[XWD PTRAC!INAC!DISTMP,INTEGR]
15000 HRRZM TEMP,$TBITS(LPSA) ;$TBITS WORD
15100 HLLZM TEMP,$SBITS(LPSA) ;$SBITS WORD
15200 PUSHJ P,RNGDIS ;PUT IT ON DISLST LIST
15300 HRRZM LPSA,ACKTAB(D) ;MARK AC FULL OF IT
15400 POPJ P, ;RETURN
15500
15600 COMMENT ⊗
15700 DSCR ZOTDIS
15800 DES this procedure will wipe out your current display
15900 PARM None
16000 SID LPSA,TEMP used
16100 ⊗
16200 ↑↑ZOTDIS:
16300 PUSH P,D ;SAVE
16400 PUSH P,A
16500 MOVE A,CDLEV ;CURRENT DISPLAY LEVEL
16600 ZDIS.1: SOJL A,ZDIS.2
16700 HRRZ D,DISTAB+1(A)
16800 CAIE D,RF ;DONT ZONK RF
16900 CAIN D, ;DONT DO ANYTHING IF NOT THERE
17000 SKIPA
17100 PUSHJ P,STORZ
17200 HLRZ D,DISTAB+1(A)
17300 CAILE D,
17400 PUSHJ P,STORZ
17500 SETZM DISTAB+1(A)
17600 JRST ZDIS.1
17700 ZDIS.2: POP P,A
17800 POP P,D
17900 POPJ P,
18000
18100 >;DIS
18200
00100 COMMENT ⊗GET
00200
00300 GENMOV(GET) generally invokes this routine.
00400 It has many purposes, depending on the entity to be "getted".
00500 Briefly, however, it loads an AC with the thing one
00600 wants in order to store or compute using the entity in
00700 question. For strings, it loads a string address
00800 with the left half negative (for popping). For
00900 INDXED guys (with ADDR turned on), it loads
01000 the result of the index calc to an ac if it was not
01100 there. For regular variables, it simply picks them
01200 up if they are not in an AC. The bits
01300 ADDR, INDX, DBL, POSIT, NEGAT, and MARK
01400 may be used to modify the action of GETOPE.
01500
01600 ⊗
01700
01800 ↑↑GET: TRNE FF,PREMASK ;ANYTHING TO DO??
01900 PUSHJ P,PRE
02000 TRC FF,INSIST!NONSTD ;IF NO MARKING TO BE DONE, AND
02100 TRCE FF,INSIST!NONSTD ; A TYPE CONVERSION WAS DONE,
02200 JRST GETOPE
02300 HRRZ TEMP,B ; (COMPARE INSISTED TYPE WITH
02400 CAIE TEMP,(TBITS) ; ACTUAL TYPE), THEN DON'T GET
02500 JRST POST ; AGAIN
02600 ↑GETOPE:
02700 PUSHJ P,ACCOP ; ESTABLISH ACCESS TO THE EFFECTIVE ADDRESS.
02800
02900 COMMENT ⊗ IF STTEMP, NO MORE WORK NECESSARY
03000 (ASSUME STRING IS ON) ⊗
03100
03200 TLNN SBITS,STTEMP
03300 JRST GETOPC
03400 TRNN FF,ADDR ;MUST GO THRU WITH IT IF ADDR
03500 JRST TMPRET
03600
03700 COMMENT ⊗ USE LEFT HALF OF A TO HOLD SOME EXTRA BITS:
03800
03900 1 -- NEED AN AC (GETAC)
04000 2 -- DO A MOVE OF SOME SORT
04100 4 -- DO A MOVN
04200 10 - MAKE IT A HRRO
04300 20 - MAKE IT A HRROI, FOR STRING INDXED GUYS (SEE BELOW)
04400 40 - SPECIAL ACCOP BIT, SEE GETRET BELOW
04500
04600 NEED EXTRA CHECKS IF ENTITY IS ALREADY IN AN AC
04700 ⊗
04800
04900 GETOPC: HRLZI A,3 ;ASSUME NEED A MOVE
05000 TRNE FF,SPAC ;UNLESS AC # PROVIDED,
05100 TLZ A,1 ; ASSUME AC NEEDED
05200 TLNN SBITS,INDXED ;IF ¬INDEXED, THEN TURN OFF NONSTD.
05300 TRZ FF,NONSTD ;SO AS NOT TO FOUL UP.
05400 NOSPAC: TLNN SBITS,INAC!PTRAC;IF IN AC, HAVE TO BE SURE IT'S RIGHT
05500 JRST STCHK ; IF NOT, MUST CHECK
05600 ; FOR STRINGS (HAVE TO LOAD)
00100
00200 Comment ⊗ INAC -- if DBL or INDX or SPAC,
00300 find out if thing can stay in this AC -- otherwise
00400 must get another. ⊗
00500
00600 ; FIRST CHECK SPAC GUYS
00700
00800 TLZ A,1!2 ;ASSUME NOTHING YET
00900 TRNN FF,SPAC ;PROVIDED WITH SPECIFIC AC?
01000 JRST DBCHK ; NO, CHECK DBL WANTED
01100 HRRZ TEMP,$ACNO(PNT) ;GET CURRENT AC #
01200 CAIN TEMP,(D) ;DID WE LUCK OUT (SAME ONE)?
01300 JRST SBSCHK ;YES, GO CHECK SPECIAL INDXED THING
01400
01500 ;DCS 8/16/70 IF SPAC AC BEING REPLACED,
01600 ; STORE AND CLEAR WHAT'S IN IT
01700 SKIPLE ACKTAB(D) ;PROTECTED OR NOTHING THERE?
01800 PUSHJ P,STORZ ; NO, GET RID OF IT
01900 ;DCS 8/16/70
02000
02100 TLO A,2 ;WILL HAVE TO DO A MOVE
02200 JRST WPCHK1 ;AND MAKE SEMANTICS CHANGES
02300
02400 ; IF DBL IS ON, SEE IF NEXT AC IS FREE, SET UP TO MOVE IF NOT
02500
02600 DBCHK:
02700 HRR D,$ACNO(PNT) ;GET CURRENT AC NUMBER
02800 TRNN FF,DBL ;WELL
02900 JRST IDXCHK ;NO DBL REQUESTED
03000
03100 SKIPGE ACKTAB+1(D) ;NEXT ONE NOT USABLE?
03200 JRST WIPCHK ; CANNOT BE USED, MAKE SEMANTIC CHANGES
03300
03400 HRRI D,1(D) ;STORE THE NEXT
03500 PUSHJ P,STORZ
03600 HRRI D,-1(D) ;RESTORE AC #
03700
03800
03900 IDXCHK: TRNE FF,INDX ;NEED INDX?
04000 TRNE D,-2 ; AND NOT IN ONE ALREADY?
04100 JRST SBSCHK ;OK, 'TWOULD SEEM
04200
04300
04400 Comment ⊗ If AC # is being changed (INAC ∧ NEEDAC ∨ SPAC ∧ MOVE)
04500 clear right half of ACKTAB(AC), but first be sure nothing will be
04600 wiped out ⊗
04700
04800 WIPCHK: TLO A,1!2 ;HAVE TO MOVE IT
04900 WPCHK1: HRRZ TEMP,$ACNO(PNT) ;IT IS HERE CURRENTLY
05000 SKIPGE ACKTAB(TEMP) ;WAS THIS AC PROTECTED?
05100 ERR <DRYROT --AC CLOBBER>,1
05200 SETZM ACKTAB(TEMP) ;"STORR" (STORL DONE BEFORE)
00100
00200 Comment ⊗ for STRING INDXED quantities (or non-STRING with ADDR)
00300 (guaranteed INAC by now) requiring a displacement,
00400 a "HRROI" FXTWO (or MOVEI)must be done --
00500 "HRRO" ("MOVE") with ADDR would yield a no-op
00600 ⊗
00700
00800 SBSCHK: TLNN SBITS,INDXED ;TEST THE CONDITONS
00900 JRST POSN ; NOT INDEXED
01000 HRRZ TEMP,$VAL(PNT) ;≠0 DISPLACEMENT?
01100 JUMPE TEMP,POSN ; NO DISPLACEMENT, NO PROBLEM
01200 TRNN TBITS,STRING ;INDXED STRING?
01300 JRST CHKNUM ; NO, CHECK GET!ADDR FOR NUMERIC ARRAY
01400 TRZ FF,ADDR ;JUST IN CASE
01500 TLO A,2!20 ;MOVE, HRROI, NO ADDR
01600 JRST POSN
01700
01800 CHKNUM: TRZE FF,ADDR ;WANT THE ADDRESS ALL TOGETHER?
01900 TLO A,100!2 ; YES, MOVE, MOVEI
02000 JRST POSN
02100
02200
02300 Comment ⊗ for strings, we must do a HRRO with ADDR
02400 turned ON (except for SBSCRP strings) ⊗
02500
02600 STCHK: TRNE FF,SPAC ;STORE AC IF SPAC
02700 PUSHJ P,STORZ
02800 TRNE TBITS,STRING ;STRING, NOT SBSCRP?
02900 TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;NOT REALLY A STRING?
03000 JRST POSN
03100 TDO A,[XWD 2!10,ADDR] ;DO A "HRRO" ADDR
03200
03300 ; IF (POSIT(A) ∧ NEGAT(SBITS)) ∨ (NEGAT(A) ∧ ¬ NEGAT(SBITS)) MUST
03400 ; DO SOMETHING ABOUT IT
03500
03600 POSN: TRNE FF,POSIT ;FIRST CONDITION
03700 TLNN SBITS,NEGAT
03800 JRST CHNGAT ; UNSATISFIED
03900 TLZ SBITS,NEGAT ;NO LONGER NEGAT
04000 TLO A,2!4 ;DO "MOVN"
04100 JRST CHKDX ;GO CHECK INDEXED
04200
04300 CHNGAT: TRNE FF,NEGAT ;SECOND CONDITION
04400 TLNE SBITS,NEGAT
04500 JRST CHKDX ; UNSATISFIED
04600 TLO SBITS,NEGAT ;NOW NEGAT
04700 TLO A,2!4 ;DO A "MOVN"
04800
04900 CHKDX: TLNE SBITS,INDXED ;IF INDXED, NOT STRING, NOT ADDR, BE
05000 TRNE TBITS,STRING
05100 JRST ADRCK ;DOES NOT NEED A HRRO, HRROI
05200 TRNN FF,ADDR
05300 TLO A,2 ; SURE SOME SORT OF MOVE GETS DONE
05400 ADRCK: TRNE FF,ADDR ;NOW COPY THIS INTO A
05500 TRO A,ADDR ;LIKE ALL CPA'S.
05600
05700
00100
00200 GETWD: TRNN FF,NONSTD ;THE NON-STANDARD TYPE WILL
00300 ;**ALWAYS** GET AN AC.
00400 TLNE A,1 ;NEED AC?
00500 PUSHJ P,GETAC ; YES, GOT IT
00600 TLNN A,2 ;NEED TO MOVE?
00700 JRST [TLNN SBITS,INAC!PTRAC ;STRIVE TO PUT BITS BACK RIGHT
00800 JRST TMPRET
00900 TLNE SBITS,INDXED
01000 JRST IDXRET
01100 JRST GETRET] ;BEST AS POSSIBLE THE SAME AS ON ENTRY
01200 MOVE TEMP,A ;SAVE BITS SO YOU CAN TEST THEM
01300 PUSH P,A ;SAVE LH BITS
01400 HRLI A,(<MOVE>) ;ASSUME "MOVE"
01500 TLNE TEMP,4 ;MOVN?
01600 HRLI A,(<MOVN>) ; YES
01700 TLNN TEMP,20!10 ;HRRO OR HRROI?
01800 JRST NOHRRO ;NO
01900 TRO A,FXTWO
02000 HRLI A,(<HRRO>)
02100 TLNE TEMP,20 ;ETC.
02200 HRLI A,(<HRROI>)
02300 NOHRRO:
02400 PUSH P,PNT
02500 TRNE TBITS,ITMVAR
02600 TLNN TBITS,MPBIND ;IF NOT ?ITEMVAR
02700 JRST NOTMPP ;CONTINUE
02800 TRZ A,ADDR
02900 ;; JRL FOLLOWING WAS MISTAKENLY A HRRI
03000 HRLI A,(<MOVEI @>)
03100 TRNE TEMP,ADDR ;ADDR REQUESTED
03200 ;; JRL FOLLOWING WAS MISTAKENLY A HRRI
03300 HRLI A,(<MOVE>)
03400 JRST EMTMOV ;EMIT THE MOVE
03500 NOTMPP: TLNE TEMP,100 ;FOR GET ADDR
03600 HRLI A,(<MOVEI>)
03700 TRO A,IMMOVE ;IF POSSIBLE
03800
03900 TRNE TBITS,ITEM ;OH MY GOSH AROODIES.
04000 JRST [TLNN TBITS,FORMAL!SBSCRP
04100 MOVE PNT,$VAL2(PNT) ; IT WILL BE AN INTEGER....
04200 JRST .+1]
04300 EMTMOV: PUSHJ P,EMITER
04400 POP P,PNT ;IN CASE OF ITEM.
04500
04600 POP P,A
04700 TLNE TBITS,MPBIND
04800 JRST [TRNN A,ADDR ;ADDR?
04900 JRST .+1 ;NO.
05000 PUSH P,A
05100 HRLZI C,20 ;INDIRECT BIT
05200 EMIT <TLZN ,USADDR!NORLC>
05300 EMIT <MOVEI ,0>
05400 POP P,A
05500 JRST .+1]
05600
05700
05800 GETRET: TRNE FF,NONSTD ;SPECIAL CASE OF PRESERVING INDXD TEMPS
05900 JRST [MOVE SBITS,$SBITS(PNT) ;RESTORE OLD MARKING.
06000 JRST TMPRT1] ;AND FINISH OUT.
06100 TLZ SBITS,PTRAC!INDXED!INAC ;START FROM SCRATCH
06200 TLNN A,20!40!100 ;INAC MARKING?
06300 JRST STDRET ; YES, DO IT
06400
06500 IDXRET: TLO SBITS,PTRAC!INDXED;KEEP INDXED BITS
06600 TLNN A,20!100 ;HRROI (MOVEI) THING?
06700 JRST ALLRET ; NO
06800 TLZ TBITS,OWN
06900 HLLZS $VAL(PNT) ; NO DISPL ANYMORE
07000 JRST ALLRET
07100
07200 STDRET: TDNN TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;NOT REALLY A STRING?
07300 TRNN TBITS,STRING ;KEEP BITS OFF IF STRING
07400 TLO SBITS,INAC
07500 ALLRET: HRRM PNT,ACKTAB(D) ;UPDATE SEMANTICS AND
07600 HRRM D,$ACNO(PNT) ; ACKTAB
07700
07800 TMPRET: MOVEM SBITS,$SBITS(PNT) ;IF ACCOP, THIS WILL BE NECESSARY
07900 TMPRT1: TRNN FF,MRK ;DOES HE WANT A MARK?
08000 JRST POST ;ALL DONE.
08100 PUSHJ P,REMOP ;AFTER ALL THAT?
08200 JRST MARK1 ;AH, WELL
00100 COMMENT ⊗STACK -- Issue Instrs. to Stack Anything on Approp. Stack⊗
00200
00300 ↑↑STACK: TRNE FF,PREMASK ;ANY TO DO?
00400 PUSHJ P,PRE
00500 PUSHJ P,STACK1
00600 TRNN FF,MRK ;HAS HE ASKED FOR A MARK?
00700 JRST POST ;FINISH OUT.
00800 JRST MARK1 ;AND DO A MARK.
00900
01000
01100 STACK1: PUSH P,FF ;SAVE
01200 DIS <
01300 TRNN SBITS,DLFLDM ;DOES HE LIVE IN THE STACK?
01400 >;DIS
01500 TLNE SBITS,INDXED
01600 PUSHJ P,ACCOP ;GET ACCESS.
01700 TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;ALWAYS STACK ARRAYS ON P-STACK
01800 JRST ASTACK ; NO MATTER WHAT
01900 TRNN FF,ADDR ;MUST BE A CALL BY REF.
02000 TRNN TBITS,STRING ;STRING STACK?
02100 JRST ASTACK ;NO -- ARITHMETIC
02200 TLNE SBITS,STTEMP ;IF STTEMP ∧ INUSE,
02300 ; ALREADY STACKED, DON'T DO AGAIN
02400 JRST MARTK ;JUST MARK AND QUIT
02500
02600
02700 MOVEI D,RSP ;TO AVOID CLOBBERING CORE.
02800 MOVE A,[PUSH RSP,STAK!BPWORD!LNWORD!ADOP!REM]
02900 PUSHJ P,STROP1 ;THIS IS REALLY EASY. DO TWO PUSHES.
03000 JRST MARTK ;AND NOW MARK THINGS.
03100
03200
03300
03400 ASTACK: TLZN SBITS,NEGAT ;ARE THINGS CURRENTLY NEGATIVE?
03500 JRST OKPO ;NO
03600 TLNN SBITS,INAC!PTRAC
03700 ERR <DRYROT -- STACK NEGAT IN CORE?>,1
03800 HRL C,$ACNO(PNT)
03900 EMIT (MOVNS USADDR!NORLC!NOUSAC)
04000 MOVEM SBITS,$SBITS(PNT);FOR THE EMITER.
04100 OKPO: TLNE TBITS,MPBIND ;A ?ITEMVAR
04200 JRST [TRNE FF,ADDR ;ADDRESS REQUIRED?
04300 ERR <DRYROT -STACK ADDR ? ITEMVAR>
04400 PUSH P,D
04500 PUSHJ P,GETAC
04600 EMIT <MOVEI @,>
04700 PUSHJ P,MARKINT
04800 POP P,D
04900 JRST .+1]
05000 HRLZI A,(<PUSH RP,>)
05100 TRNE FF,ADDR ;COPY THIS BIT.
05200 TRO A,ADDR
05300 TRO A,NOUSAC ;WE HAVE SPECIFIED IT.
05400 PUSHJ P,EMITER ;PUT OUT THE PUSH.
05500 AOS ADEPTH ;SINCE WE USED THE PSTACK
05600 MARTK: PUSHJ P,REMOP ;REMOVE THE THING YOU'RE STACKING
05700 MOVE SBITS,$SBITS(PNT);GET ITS BITS BACK FOR THE REST OF THIS
05800 MARTH: POP P,FF ;RESTORE
05900 POPJ P,
00100 COMMENT ⊗MARK, MARKINT, MARKME -- Mark Semblk with Correct Temp Semantics
00200 This marks the AC (D) with a temp descriptor of type in SBITS, TBITS⊗
00300
00400 ↑↑MARK: TRNE FF,PREMASK ;
00500 PUSHJ P,[TRNE FF,657777
00600 ERR <MARK>,1
00700 JRST PRE]
00800 PUSHJ P,MARK1
00900 JRST POST ;ALL DONE.
01000
01100 MARK1: ANDI TBITS,MASK ;WANT ONLY THE TYPE BITS (NOT FORMAL,ETC.)
01200 TLZ SBITS,CORTMP!PTRAC!INDXED!FIXARR
01300 ;;#HS# JRL AN ITEMVAR IS NOT ITS DATUM
01400 TRNE TBITS,ITMVAR!ITEM
01500 JRST .+3
01600 ;;#HS#
01700 TRNE TBITS,STRING ;IF STRING TYPE, THEN
01800 JRST STMARK
01900 TLO SBITS,INAC!ARTEMP!INUSE ;SINCE HE MAY NOT HAVE SET THEM.
02000 TLZ SBITS,STTEMP
02100 HRRE LPSA,ACKTAB(D) ;PICK UP TEMP DESCIRIPTOR
02200 JUMPLE LPSA,NOTEM ;IF NO TEMP OR REMOPPED TEMP
02300 MOVE USER,$SBITS(LPSA) ;GET SEMANTIC BITS
02400 TLNN USER,INUSE ;A TEMP?
02500 JRST REMM ;NO
02600 TLNN USER,CORTMP ;A CORE TEMP?
02700 JRST USOLD ;NO -- USE THE TEMP THAT IS THERE.
02800 TLNE USER,INAC ;IS IT STILL IN THE ACCUMULATOR?
02900 PUSHJ P,STORA ;YES --STORE IT.
03000
03100 SKIPA
03200 REMM: PUSHJ P,CLEARL ;DO THE REMOP
03300 NOTEM: PUSHJ P,GETTEM ;GET A NEW TEMPORARY
03400 USOLD: HRRM LPSA,ACKTAB(D) ;INSERT IN AC TABLE RIGHT HALF
03500 HRRM D,$ACNO(LPSA) ;AND THE LOGICAL INVERSE.
03600 MARKT: HRRZM LPSA,PNT ;
03700 SETZM $VAL(PNT)
03800 MARTS: POPJ P,
03900 STMARK: TLO SBITS,STTEMP ;IN CASE IT SKIPS AND NOONE ELSE DID
04000 TLZ SBITS,ARTEMP
04100 HRRZ LPSA,PNT ;IN CASE STRTMP NOT CALLED
04200 TLNN SBITS,INUSE ;ALREADY HAS A TEMP?
04300 PUSHJ P,STRTMP ;GET A STRING TEMP.
04400 JRST MARKT
04500
04600 DSCR MARKINT, MARKME
04700 DES THESE ARE ROUTINES TO HELP YOU CALL "MARK"
04800 MARKINT -- ALWAYS MARKS A VANILLA INTEGER, RETURNS DESCR. IN PNT,SBITS,TBITS.
04900 MARKME -- YOU SPECIFY TBITS, SBITS=0 IS ASSUMED
05000 ⊗;
05100 ↑↑MARKINT: MOVEI TBITS,INTEGR ;MARK AN INTEGR,
05200 ↑↑MARKME: HRRI FF,0
05300 SETZ SBITS,
05400 JRST MARK1
00100 COMMENT ⊗INCOR -- Issue Code to Clear this Entity from ACs⊗
00200
00300 DSCR INCOR
00400 DES makes sure that the entity mentioned in PNT,TBITS,SBITS is really
00500 in core. If not, the AC entry for that entity is cleared.
00600 The updated Semantics bits are returned in SBITS.
00700 ⊗;
00800
00900 ↑↑INCOR:
01000 TLZN SBITS,INAC!PTRAC ;GONE?
01100 POPJ P, ;ALL DONE!
01200 PUSH P,D ;SAVE THIS.
01300 HRRZ D,$ACNO(PNT) ;PICK UP RELEVANT AC.
01400 PUSHJ P,STORZ
01500 POP P,D
01600 JRST GETAD ;ALAS, SINCE STORZ WILL CHANGE THINGS.
00100 COMMENT ⊗REMOPs, CLEARs -- Remove Temps, ACs, from Use⊗
00200
00300 DSCR REMOP,REMOPA,REMOPL,REMOP2
00400 DES These are the REMOP routines. They say, in effect, "I am
00500 finished with this argument. If it was a temp descriptor, then I
00600 am really finished, and the temp may be returned to the pool of
00700 such temps. If it was a simple variable or constant, etc. then no
00800 action is taken.
00900
01000 PAR The differences among the routines are only in the call form:
01100 REMOP -- PNT has pointer to entity.
01200 REMOPL -- LPSA has pointer to entity
01300 REMOPA -- D has AC number of entity.
01400 REMOP2 -- PNT2 has pointer to entity.
01500
01600 SID AC'S USED: LPSA,TEMP,USER
01700 ⊗;
01800
01900
02000 ↑REMOP2: MOVE LPSA,PNT2
02100 JRST REMOPL
02200 ↑REMOPA: SKIPA LPSA,ACKTAB(D) ;REMOP BY ACCUMULATOR NUMBER
02300 ↑REMOP: MOVE LPSA,PNT ;OH WELL.
02400 ↑REMOPL: TRNN LPSA,-1
02500 POPJ P, ;NONE THERE.
02600 MOVE TEMP,$SBITS(LPSA);THE STANDARD REMOP
02700 TLNN TEMP,STTEMP!ARTEMP!INUSE ;A REAL TEMP?
02800 POPJ P, ;NO -- GO AWAY.
02900 DELAL: MOVSI USER,INUSE!STTEMP!INAC!PTRAC!NEGAT!FIXARR ;TURN THESE OFF
03000 ANDCAM USER,$SBITS(LPSA) ;IN MEMORY.
03100 HRRZ USER,$ACNO(LPSA) ;GET THE AC IT WAS IN
03200 TLNN TEMP,INAC!PTRAC ;WAS IT IN AN AC?
03300 JRST CTCHK ;NO -- ALL DONE.
03400 SKIPGE ACKTAB(USER) ;YES --TURN IT OFF.
03500 ERR <DRYROT -- REMOP>,1
03600 SETZM ACKTAB(USER)
03700 CTCHK: TLNE TEMP,INUSE ;If this was still an alive temp, and
03800 TLNE TEMP,CORTMP ; was not a CORTMP, thus contains no fixups
03900 POPJ P, ; or anything, we can release it to free
04000 PUSH P,LPSA ; storage. Otherwise, leave it on the TTEMP
04100 PUSHJ P,BLKFRE ; list (where it MUST be), and forget it.
04200 POPJ P,
04300
04400
04500 DSCR CLEAR,CLEARL,CLEARA
04600 DES These are routines to clear an entry in the AC table (ACKTAB)
04700 That is, all memory of what is in the AC is lost. The difference
04800 among the routines is the call form:
04900
05000 PAR CLEAR -- PNT has pointer to entity to be "cleared"
05100 If it turns out not to be in an AC, no action is taken.
05200 CLEARL -- LPSA has pointer; same deal.
05300 CLEARA -- D has AC number to be cleared.
05400
05500 SID AC'S USED: LPSA,TEMP
05600 ⊗;
05700
05800 ↑CLEAR: MOVEI LPSA,(PNT) ;CLEAR OUT AN AC TABLE ENTRY.
05900 ↑CLEARL: MOVE TEMP,$SBITS(LPSA) ;SEE IF IT IS IN AN AC.
06000 TLNN TEMP,INAC!PTRAC ;IF NOT -- ALL DONE.
06100 POPJ P, ;DONE.
06200 MOVE TEMP,$ACNO(LPSA) ;AC IT IS IN.
06300 SETZM ACKTAB(TEMP) ;AND ZERO THE ENTRY.
06400 JRST CLR1 ;FINISH OUT.
06500 ↑CLEARA: MOVEI LPSA,0 ;
06600 EXCH LPSA,ACKTAB(D) ;ZERO AC TABLE ENTRY.
06700 CLR1: MOVSI TEMP,INAC!PTRAC!NEGAT
06800 TRNE LPSA,-1 ;ANYTHING THERE? (DCS -- 8/16/70)
06900 ANDCAM TEMP,$SBITS(LPSA) ;TURN THESE OFF IN MEMORY.
07000 POPJ P,
00100 COMMENT ⊗STROP -- Bit-Driven String Operation Code Generator⊗
00200
00300 DSCR STROP
00400 DES This routine is willing to do lots of twiddling on strings.
00500 It knows about reference strings, etc.
00600 PAR A is an instruction for the EMITTER, with some bits in
00700 it to say what things should be done with this instruction.
00800 Bits in A: bpword -- issue the instruction for
00900 the byte pointer word.
01000 lnword -- or for the length word.
01100 bpfirst -- issue the byte pointer inst. first.
01200 adop -- this is an instruction which adds to stack.
01300 sbop -- this is an instruction which subs from stack.
01400 undo -- so a SUB SP,X22 at end.
01500 rem -- do a remop when done.
01600
01700 stak -- used internally.
01800 bpinc -- byte pointer instruction is in c(rh)
01900
02000 PNT,TBITS,SBITS -- semantics of string.
02100
02200 D -- accumulator to use for ac field of op.
02300 Thus, it must be RSP if that stack is to be used.
02400 ⊗;
02500
02600
02700 ↑STROP: CAIN D,RSP ;IF THE STACK,
02800 TRO A,STAK ;THEN MARK AS SUCH.
02900 DPB D,[POINT 4,A,12] ;SAVE IN AC FIELD OF INSTRUCTION.
03000 PUSHJ P,ACCOP ;AND GET ACCESS TO THE ROUTINE.
03100 ;THIS UPDATES SBITS IN CORE.
03200 STROP1: PUSH P,ACKTAB(D) ;PROTECT.
03300 SETOM ACKTAB(D)
03400 PUSH P,D ;SAVE AC.
03500 TLNN TBITS,REFRNC ;THE HARD CASE.
03600 JRST OPPP1 ;
03700 PUSH P,A ;SINCE GETOPE DOES NOT PRESEVE.
03800 HRRI FF,ADDR!INDX
03900 PUSHJ P,GETOPE ;GET THE ADDRESS OF THE BP WORD IN AN AC.
04000 ;THIS UPDATES SBITS IN CORE.
04100 SETZM ACKTAB(D) ;WE DO NOT WANT TO SEE THIS AGAIN.
04200 HRLZS D ;READY FOR INDEXING.
04300 POP P,A
04400 OPPP1: TLNE SBITS,STTEMP ;IF STACKED, THEN NEED
04500 HRLI D,RSP ;THE STACK
04600 HRRI FF,(A) ;SAVE BITS.
04700 TRNE FF,BPFIRST ;IF BYTE POINTER WORD FIRST, DO IT
04800 PUSHJ P,BP
04900 PUSHJ P,LN ;NOW THE LENGTH
05000 TRNN FF,BPFIRST
05100 PUSHJ P,BP
05200
05300 TRNE FF,UNDO
05400 TLNN SBITS,STTEMP ;IF UNDO AND A STACKED STRING.
05500 JRST OP2 ;
05600 PUSHJ P,SUBIT
05700 OP2: POP P,D ;RESTORE.
05800 POP P,ACKTAB(D)
05900 TRNE FF,REM ;IF REMOP ASKED FOR.
06000 JRST REMOP
06100 POPJ P, ;ALL DONE.
06200
06300
06400 DSCR SUBIT
06500 DES Emits a SUB SP,[XWD 2,2], and subtracts two from SDEPTH.
06600 ⊗;
06700 ↑SUBIT: PUSH P,A
06800 MOVE A,X22 ;SUBTRACT TWO FROM THE STACK.
06900 PUSH P,PNT
07000 PUSHJ P,CREINT
07100 EMIT (<SUB RSP,NOUSAC>) ;THEN ISSUE THE SUBS.
07200 PUSHJ P,REMOP ;JUST IN CASE
07300 POP P,PNT
07400 MOVNI A,2
07500 ADDM A,SDEPTH ;UPDATE COUNT.
07600 POP P,A
07700 JRST GETAD ;RESTORE TBITS,SBITS.
07800
07900 BP: TRNN FF,BPWORD ;ONLY IF ASKED FOR.
08000 POPJ P,
08100 PUSH P,A ;SAVE
08200 TRNE FF,BPINC ;IF ANOTHER INSTRUCTION AROUND.
08300 DPB C,[POINT 9,A,8] ;IN INSTRUCTION PARTS.
08400 HRRI A,NOUSAC!FXTWO ;TENTATIVE BITS TO EMITER.
08500 TLNN SBITS,STTEMP ;IF ON STACK OR
08600 TLNE TBITS,REFRNC ;BUT IF THIS CASE, THEN
08700 TRC A,FXTWO!NORLC!USX!USADDR
08800 HRLI C,0 ;WITH NO DISCPLACEMENT.
08900 PUSHJ P,EMITER
09000 POP P,A
09100 JRST FINBP
09200
09300 LN: TRNN FF,LNWORD ;ONLY IF ASKED
09400 POPJ P,
09500 HRRI A,NOUSAC
09600 TLNN SBITS,STTEMP ;IF TEMP OR
09700 TLNE TBITS,REFRNC ;REFERENCE, THEN MUST USE
09800 TRO A,NORLC!USX!USADDR ;INDEXING ETC.
09900 HRLI C,-1 ;ANO THIS TIME A DISPLACEMENT.
10000 PUSHJ P,EMITER
10100
10200 FINBP: TRNE FF,ADOP!SBOP ;PREPARE TO ADJUST STACK.
10300 TRNN FF,STAK ;ONLY IF ON STACK.
10400 POPJ P, ;NONE.
10500 TRNE FF,ADOP
10600 AOSA SDEPTH
10700 SOS SDEPTH ;OUR BOOKKEEPING DONE,
10800 POPJ P, ;WE DEPART.
00100 COMMENT ⊗GETTEM, etc. -- Temp Semblk Allocators⊗
00200
00300 DSCR GETTEM,GETCRTMP,STRTMP
00400 DES Routines for getting temp descriptor Semblks. The list of
00500 free temps is searched for an appropriately free one. If found,
00600 a masked form of TBITS, and a masked form of SBITS are stored
00700 in the Semblk for this temp. A pointer to it is returned in LPSA
00800 INCL more descriptions about temps, their numbers, how they're
00900 moved, kept track of, deleted, depend on procedures, etc.
01000
01100 GETTEM -- get a non-core temp
01200 STRTMP -- get a String temp (i.e. turn on the STTEMP bit in SBITS)
01300 GETCRTMP -- get a core temp.
01400
01500 SID AC'S USED: USER,LPSA,TEMP
01600 ⊗;
01700
01800 STRTMP: TLOA SBITS,INUSE!STTEMP
01900 ↑GETTEM: TLO SBITS,INUSE!ARTEMP ;TURN ON TEMP BITS.
02000 TLZ SBITS,CORTMP
02100 GETBLK ;GET A NEW BLOCK
02200 GTT1: MOVEM SBITS,$SBITS(LPSA)
02300 ANDI TBITS,MASK
02400 MOVEM TBITS,$TBITS(LPSA) ;GOOD BITS IN MEMORY
02500 POPJ P, ;NOTHING ELSE TO DO
02600
02700 ↑GETCRTMP: ;GET A CORE TEMP
02800 SKIPA LPSA,TTEMP
02900 STRG: LEFT ,%RVARB,NOFF
03000 MOVE TEMP,$SBITS(LPSA)
03100 TLNE SBITS,CORTMP
03200 TLOE TEMP,INUSE
03300 JRST STRG
03400 DDRET: MOVSI SBITS,INUSE!CORTMP!ARTEMP
03500 JRST GTT1 ;FINISH OUT AS ABOVE.
03600
03700 NOFF: PUSHJ P,GETTEM
03800 AOS TEMP,TEMPNO ;INCREMENT TEMP ID NO
03900 MOVEM TEMP,$PNAME(LPSA) ;STORE IN $PNAME FOR ADCON AND SCOUT
04000 SETZM $ADR(LPSA) ;AND ZERO THE FIXUP.......
04100 PUSHJ P,RNGTMP
04200 JRST DDRET
00100 COMMENT ⊗GETAC, GETAN0 -- AC Allocators⊗
00200
00300 DSCR GETAC,GETAN0
00400 DES These are the "get a free AC routines".
00500 PAR FF(rh) -- two modifier bits:
00600 DBL -- get a double AC (i.e. next one free too)
00700 INDX -- get an indexable AC (not 0 or 1 -- 1 is avoided since
00800 Procedures tend to return values in 1).
00900 RES in D is returned the free (first free) AC number
01000 Note that no ACKTAB marking has been done yet, so the AC
01100 need not be used.
01200
01300 GETAN0: same as GETAC, but INDX is autimatically turned on.
01400
01500 AC'S USED: TEMP,LPSA
01600 ⊗;
01700
01800 ↑GETAN0: TRO FF,INDX ;HERE IF YOU DON'T WANT TO SET THE BIT
01900 ↑GETAC:
02000 HRR D,ACKPNT ;LAST AC USED
02100 SETOM ACKPNT ;CLEAR IT
02200 SETZM POSSIB ;MASK OF POSSIBILITIES
02300 MOVNI TEMP,20 ;NUMBER OF AC'S TO SEARCH
02400
02500 ;;#HF# 5-13-72 DCS RETURN OLDEST AVAILABLE AC IF NONE FREE, FIX DBL
02600 GET1: AOJG TEMP,GET7 ;For each AC, starting with the one
02700 ADDI D,1 ; after the last allocated, and wrapping
02800 TRZ D,777760 ; around to 0 (2 if GETAN0), if the AC
02900 TRNE FF,INDX ; is not protected (ACKTAB(AC)<0),
03000 TRNE D,-2 ; record the (oldest) first one seen in
03100 SKIPGE LPSA,ACKTAB(D) ; ACKPNT -- if the entry is free (0),
03200 JRST GET1 ; try to terminate. Otherwise, continue
03300 SKIPGE ACKPNT ; looking for a free one.
03400 HRRZM D,ACKPNT
03500 TRNN LPSA,-1
03600 JRST GET4
03700 JRST GET1
03800
03900 ; ONE FREE ONE EXISTS -- JUST RECORD IF DBL (NEED TWO)
04000
04100 GET4: TRNN FF,DBL ;If only one AC is needed, it's number
04200 JRST DSTORZ ; is in D.
04300
04400 GET3: MOVEI LPSA,1 ;Otherwise, record its number in the
04500 LSH LPSA,(D) ; bit array POSSIB. This is not the
04600 IORM LPSA,POSSIB ; most efficient method, but it allows
04700 JRST GET1 ; the fun below.
04800
04900 ; LIST EXHAUSTED -- TAKE WHAT WE COULD GET
05000
05100 GET7: TRNE FF,DBL ;If two were needed, we must work
05200 JRST GET9 ; harder.
05300 DIS <
05400
05500 ; TAKE A DISPLAY TEMP FIRST
05600
05700 SKIPE DISLST ;ONLY ANY GOOD IF HAVE SOME
05800 SKIPG LPSA,CDLEV ;CURRENT DISPLAY LEV
05900 JRST GET7.1
06000 HRRI D,1 ; COULD NEVER BE ZERO OR 1
06100 GET7.2: SKIPE DISTAB(D)
06200 JRST GET7.3 ;THIS THING HAS AN AC
06300 AOS D ;TRY THE NEXT ONE UP
06400 SOJG LPSA,GET7.2
06500 ERR <DRYROT AT GETAC> ;YOU REALLY BLEW IT, SAM
06600 GET7.3: MOVE LPSA,DISTAB(D) ;PICK IT UP
06700 TLNE LPSA,-1 ;USE STRING DISPLY IF WE CAN
06800 MOVSS LPSA ;US STRING -HURRAH
06900 CAIN LPSA,RF ;
07000 JRST GET7.1 ;IF RF, THEN NO GO
07100 HRR D,LPSA ;WE CAN GRAB THIS ONE
07200 SKIPG ACKTAB(D)
07300 ERR <GETAC GRABBED SAFE AC -- DRYROT AND WORMS>
07400 JRST DSTORZ ;RECORD IT, CLEAR IT OUT
07500 GET7.1:
07600 >;DIS
07700
07800 ; NO DISPLAY TEMP, CLEAR SOMETHING ELSE OUT AND USE IT.
07900
08000 HRR D,ACKPNT ;Use the first one recorded, which
08100 JRST STORZ ; is also the oldest found
08200
08300 ; WE NEED TWO -- TRY FOR TWO UNUSED IN A ROW
08400
08500 GET9: MOVE LPSA,POSSIB ;If any two in a row were free,
08600 LSH LPSA,1 ; the AND of the bits and 2*bits
08700 AND LPSA,POSSIB ; will yield a bit for each pair.
08800 JUMPE LPSA,G10 ;No bits implies no pairs.
08900 FSC LPSA,231 ;The FSC shifts the first match
09000 LDB LPSA,[POINT 4,LPSA,8] ; to a normalized position, and
09100 MOVEM LPSA,ACKPNT ; records its index in the exponent
09200 HRR D,LPSA ; field.
09300 POPJ P,
09400
09500
09600 G10: HRRI D,21 ;As a last resort, take the first
09700 G11: SUBI D,2 ; two unprotected ACs available.
09800 TRNE D,777000 ;If none are found, complain bitterly.
09900 ERR <DRYROT AT DBL GETAC> ;This could be improved by
10000 SKIPL LPSA,ACKTAB(D) ; looking for the oldest pair, and/or
10100 SKIPGE ACKTAB-1(D) ; a pair with one free AC, but at
10200 JRST G11 ; this point, we're sort of beyond
10300 JUMPE LPSA,.+2 ; caring.
10400 PUSHJ P,STORZ ;Store the second, if it needs it.
10500 SUBI D,1 ;This is the result.
10600
10700 DSTORZ: HRRZM D,ACKPNT ;Allocating this one. Now go make
10800 JRST STORZ ; sure it's ready for new action.
10900 ;;#HF#
00100 COMMENT ⊗AC Store routines -- BOLSTO, FORSTO, STORIX, GOSTO, STORZ⊗
00200
00300 DSCR BOLSTO
00400 DES Special Boolean store. It does not remove from ACs any
00500 of the arguments to the Boolean compare.
00600 PAR PNT and PNT2 must point to Semantics of the two arguments.
00700 RES All other ACs are stored. The Semantics of the parameters
00800 are not necessarily guaranteed over the call, since either
00900 may have been marked for storing.
01000 SEE STORZ, which it calls for each AC cleared
01100 ⊗;
01200
01300
01400 ↑BOLSTO: PUSH P,[PUSHJ P,[
01500 HRRZ TEMP,LPSA
01600 CAIE TEMP,(PNT2)
01700 CAIN TEMP,(PNT)
01800 POPJ P,
01900 JRST STORZ]] ;DO TURN OFF ACSAME FOR THESE GUYS.
02000 ; THIS STORZ IS NEEDED BECAUSE A PARTICULAR BOOLEAN MAY LOOK LIKE:
02100 ; MOVE 4,I
02200 ; SKIPN J
02300 ; JRST FOO1
02400 ; MOVE 4,J+K
02500 ; SKIPE GH
02600 ; JRST SHIT
02700 ;FOO1: ..... HERE THE COMPILER THINKS J+K IS IN 4, WHERE I MIGHT BE!!!
02800 ;
02900
03000 JRST GG0
03100
03200 DSCR FORSTO
03300 DES Special AC dumper for FOR Loops. This protects the index
03400 AC from being cleared. Other variables are not cleared, just
03500 stored if temps.
03600 PAR PNT and PNT2 should point to anything to be preserved
03700 over this operation (e.g. FOR I← <EXP> STEP .... want to preserve
03800 I and the Semantics of <EXP> from storing before the test.
03900 SEE STORA, which it calls for each AC stored.
04000 ⊗;
04100
04200 ↑FORSTO: PUSH P,[PUSHJ P,[HRRZ TEMP,ACKTAB(D) ;FOR FOR LOOPS.
04300 CAIE TEMP,(PNT)
04400 CAIN TEMP,(PNT2)
04500 POPJ P,
04600 ;DCS -- 8/16/70
04700 PUSHJ P,STORA ;STORE IT FOR SURE
04800 JUMPE LPSA,NSBSC ;NOTHING TO CLEAR
04900 MOVE TEMP,$TBITS(LPSA) ;IF AN INAC ARRAY,
05000 TLNE TEMP,SBSCRP ;CLEAR IT, BECAUSE WILL
05100 JRST CLEARL ;STILL BE ASSUMED INAC AT
05200 NSBSC: POPJ P, ; LOOP TOP OTHERWISE
05300 ]] ;DCS -- 8/16/70
05400
05500 JRST GG0
05600
05700
05800 DSCR STORIX
05900 DES "Store" all INTERNALs and EXTERNALs, i.e. forget that
06000 they are in ACs.
06100 ⊗;
06200 ↑STORIX: PUSH P, [PUSHJ P,[
06300 HRRZ LPSA,ACKTAB(D)
06400 JUMPE LPSA,CPOPJ ;NOTHING THERE.
06500 MOVE LPSA,$TBITS(LPSA)
06600 TLNE LPSA,INTRNL!EXTRNL
06700 JRST CLEARA
06800 POPJ P,]]
06900 JRST GG0
07000
07100
07200 DSCR ALLSTO
07300 DES Dump all ACs in the most permanent of ways. Do not
07400 retain any marking of the AC's at all.
07500
07600 SEE STORZ, which it calls for each AC gronked.
07700 ⊗;
07800
07900 ↑ALLSTO: PUSH P,[PUSHJ P,STORZ] ;TO CLEAR INAC" BITS.
08000 SKIPA
08100
08200 DSCR GOSTO
08300 DES Store any AC's marked with temps (as opposed to variables).
08400 Leave the AC markings as they are.
08500 ⊗;
08600
08700 ↑GOSTO: PUSH P,[PUSHJ P,STORA]
08800 GG0: PUSH P,D
08900 MOVEI D,20 ;D, WHO WILL HAVE A COUNT
09000 G1: SOJL D,ALLD ;COUNT DOWN
09100 SKIPG LPSA,ACKTAB(D) ;DO WE HAVE A STORE TO DO?
09200 JRST G1 ;NO -- GO AHEAD
09300 XCT -1(P) ;EXECUTE STORING ROUTINE.
09400 JRST G1
09500
09600 ALLD: POP P,D
09700 POP P,(P) ;THROW AWAY
09800 POPJ P, ;AND RETURN
09900
10000
10100 DSCR STORZ
10200 DES "Store" this AC and wipe out the ACKTAB entry -- clear
10300 INAC-type SBITS in the Semantics which were there.
10400 PAR AC # in D
10500 SEE STORA,CLEARA routines, which it calls
10600 ⊗;
10700
10800 ↑STORZ: PUSHJ P,STORA
10900 JRST CLEARA
00100 COMMENT ⊗ STORA -- main AC-storing subr. -- called by above⊗
00200
00300 DSCR STORA
00400 DES Stores temp results that are in a specified AC into
00500 a core temp. If a temp exists in that AC, an appropriate core
00600 temp is found, and the Stoe is EMITted.
00700 Then the SBITS word in the Semantics is updated to
00800 reflect the "In Core" status (e.g. CORTMP bit, fixup
00900 chain addr, etc.) The fixup chain may have originated
01000 in another temp entry, but was moved here to avoid searching
01100 up the Semantic stack for all who refer to this temp and
01200 changing the addresses of the entry they point to. WHAT????
01300
01400 PAR D contains AC # affected.
01500 SID LPSA, TEMP used
01600 ⊗;
01700
01800 ↑STORA: SKIPG LPSA,ACKTAB(D)
01900 POPJ P, ;NOTHING THERE.
02000 PUSH P,SBITS
02100 MOVE SBITS,$SBITS(LPSA);GET SEMANTIC BITS.
02200 TLNN SBITS,INAC!PTRAC ;IF NOT IN AC, THEN TROUBLE
02300 ERR <STORA A THING NOT IN AC>,1
02400 NODIS <
02500 TLNN SBITS,ARTEMP ;IF NOT A TEMP, THE PROCESS IS A NO-OP
02600 >;NODIS
02700 DIS <
02800 ;; #KQ BY JRL (11-30-72) IGNORE FIXARS
02900 TLNN SBITS,FIXARR ;A FIXARR SHOULDN'T GET STORED
03000 TLNN SBITS,ARTEMP!DISTMP ;OTHERWISE A NOOP
03100 >;DIS
03200 JRST ZER
03300 PUSH P,PNT
03400 PUSH P,A
03500 MOVEI PNT,(LPSA)
03600
03700 ;BUG TRAP
03800 HRRZ TEMP,$ACNO(PNT) ;THIS IS THE AC IT THINKS ITS IN.
03900 CAIE TEMP,(D) ;THE SAME
04000 ERR <STORA>,1
04100
04200 DIS <
04300 TLNE SBITS,DISTMP ;DISPLAY????
04400 JRST ZERDR ;YES
04500 >;DIS
04600
04700 TLNE SBITS,CORTMP ;CAN WE PUT IT WHERE WE PUT IT BEFORE?
04800 JRST DEP ; YES (USUALLY ONLY HAPPENS WHEN SOME
04900 ; BUG PROVOKES IT --LIKE MISSING REMOP)
05000 SKIPA LPSA,TTEMP ;PREPARE TO SEARCH TEMP LIST
05100 TEML: LEFT ,%RVARB,NOFND ;GO DOWN TEMP LIST
05200 MOVE TEMP,$SBITS(LPSA)
05300 TLZE TEMP,INUSE ;NEED ONE NOT IN USE
05400 JRST TEML
05500 TLZN TEMP,CORTMP ;AND IN CORE
05600 JRST TEML ;REALLY AN ERROR
05700 MOVE TEMP,$ADR(LPSA)
05800 MOVEM TEMP,$ADR(PNT) ; HO HO.
05900 MOVE TEMP,$PNAME(LPSA) ;ID NUMBER OF THIS CORTMP
06000 MOVEM TEMP,$PNAME(PNT) ;SO ADRINS AND SCOUT DON'T GET CONFUSED
06100 PUSHJ P,URGTMP ;REMOVE FROM RING
06200 FREBLK () ;THE OLD ONE
06300 JRST DEP1
06400
06500 NOFND: SETZM $ADR(PNT) ;WITH ZERO FIXUP
06600 ;; #JRL ALWAYS GIVE CORTMPS ID NO.
06700 AOS TEMP,TEMPNO ;CORTMP ID
06800 MOVEM TEMP,$PNAME(PNT)
06900 ;; #JRL
07000 DEP1: MOVE LPSA,PNT
07100 PUSHJ P,RNGTMP ;PUT ON RING
07200 DEP: MOVSI SBITS,CORTMP!INUSE!ARTEMP
07300 IORB SBITS,$SBITS(PNT) ;INDICATE THE NEW STATUS
07400 TURNOF: MOVSI LPSA,INAC!PTRAC!NEGAT ;TEMP NO LONGER IN AC
07500 ANDCAM LPSA,$SBITS(PNT)
07600 HRRM D,(PNT)$ACNO ;RECORD THE AC NUMBER
07700 HRLZI A,(<MOVEM>)
07800 TLNE SBITS,INDXED ;A CALCULATED SUBSCRIPT?
07900 TRO A,ADDR ;YES -- DO NOT STORE INDIRECT.
08000 TLNE SBITS,NEGAT ;IS THE AC AROUND NEGATIVELY?
08100 HRLI A,(<MOVNM>) ;YES
08200 PUSHJ P,EMITER
08300 ;NOTE THOUGH THAT NEGAT MAY STILL
08400 ;BE ON. THIS MAY BE DANGEROUS.
08500 MOVEM SBITS,$SBITS(PNT)
08600 ZRET: POP P,A
08700 POP P,PNT
08800
08900 ZER: POP P,SBITS
09000 POPJ P, ;RETURN
09100 DIS <
09200 ZERDR: MOVE A,$VAL(PNT) ;ZEROING MASK
09300 HRR LPSA,$ADR(PNT) ;PICK UP DISPLAY LEVEL
09400 ANDM A,DISTAB(LPSA) ;ZERO APPROPRIATE SIDE OF DISTAB WORD
09500 HLLZS ACKTAB(D) ;ZONK THE ACKTAB ENTRY
09600 MOVE LPSA,PNT
09700 PUSHJ P,URGDIS ;UNLINK FROM DISPLAY VARB RING
09800 FREBLK (PNT)
09900 JRST ZRET
10000 >;DIS
10100 SUBTTL CODE EMITTER
00100 COMMENT ⊗EMITER -- Descriptions of Routine and Control Bits⊗
00200
00300 DSCR EMITER -- code emitting routine.
00400
00500 DES From input parameters and symbol table information,
00600 generate a word of real live code.
00700
00800 PAR
00900 A -- OPCODE in LH, bits in RH:
01000 NOUSAC←←400000 ;DON'T USE D(RH) AS AC #
01100 USCOND←←200000 ;USE C(RH) AS 3 BITS OF CONDITION
01200 USADDR←←100000 ;USE C(LH) AS DISPLACEMENT PART
01300 USX ←← 40000 ;USE D(LH) AS INDEX REG
01400 NORLC ←← 20000 ;RELOCATE NOT!
01500 IMMOVE←← 10000 ;IF OPERAND CONSTANT, LOAD IT ANY WAY POSSIBLE
01600 INDRCT←← 4000 ;INDIRECT ADDRESSING REQUIRED
01700 JSFIX ←← 2000 ;JUST DO A FIXUP (DON'T GET SEMANTICS).
01800 NOADDR←← 1000 ;NO EFFECTIVE ADDRESS PART
01900 ADDR ←← 400 ;WE WANT THE ADDRESS OF THIS ENTITY
02000 FXTWO←← 100 ;USE SECOND FIXUP WORD
02100
02200 C -- DISPLACEMENT (if provided) in LH, condition bits in RH
02300 D -- Index number in LH, AC number in RH (both optional)
02400 PNT -- symbol table pointer, if required
02500
02600 RES Code is written, RELOC bit is set to final value;
02700 Formal fixup list (FORMFX) has been updated, if necessary.
02800
02900 SID All Ac's are saved except TEMP and LPSA.
03000 ⊗;
03100
03200 BIT2DATA (EMITTER)
03300 INDIR ←← 20 ;THE INDIRECT BIT!!
03400 ;PNTROP ←← 200 ;THIS OPERATION WILL DO POINTER INDEXING
03500 ; (PURELY LOCAL BIT, BUT DON'T SEND IT IN)
03600 IMMED ←← 1000 ;THE IMMEDIATE BIT (FOR SOME THINGS).
03700
03800
03900 NOGAG <
04000 ↑XCALLQ: PUSH P,C ;LITTLE ROUTINE
04100 HRL C,PCNT ;FOR CALLING LIBRARY ROUTINES.
04200 EXCH C,(A) ;FIXUP INTO LIBRARY TABLE.
04300 EMIT (<PUSHJ RP,NOUSAC!USADDR>)
04400 POP P,C
04500 POPJ P,
04600 >;NOGAG
04700
00100 COMMENT ⊗ EMITER Routine⊗
00200
00300 ↑EMITER:
00400 PUSH P,A ;SAVE THOSE THINGS WHICH MIGHT CHANGE
00500 PUSH P,C
00600 PUSH P,D
00700 PUSH P,TBITS
00800 PUSH P,SBITS
00900 TRZ A,PNTROP ;ASSUME NO POINTER OP
01000 ;;# # DCS 3-25-72 Eliminate bad array address problem
01100 ;;# # When [0,0,0]-word of array (location known, no fixup) falls
01200 ;;# # on reladr 0 of .REL file, CODOUT will mistake the 0 addr field
01300 ;;# # for end of fixup chain, will inhibit RELOC -- want RELOC in this
01400 ;;# # case. A bad fix, should be more generally solved.
01500 TLO FF,RELOC!FFTMP1 ;AND RELOC (FFTMP1 FOR CODOUT 0-TEST)
01600 ;;# #
01700 TRNE A,USADDR ;ADDR IN C(LH)?
01800 JRST EAC ;YES, BYPASS SEMANTICS TESTING
01900 TLZ FF,RELOC ;NOW ASSUME NO RELOCATION
02000 HRRZS C ;CLEAR DISPLACEMENT FLD -- C(LH)
02100 TRNE A,NOADDR ;IS THERE AN ADDRESS FLD AT ALL?
02200 JRST EAC ;NO, FINISH UP
02300 TRNE A,JSFIX
02400 JRST EVAR ;GO DO A FIXUP
02500
02600 ; NOW GET SEMANTICS AND DISPATCH TO CORRECT ROUTINE TO OUTPUT INSTR
02700
02800 MOVE SBITS,$SBITS(PNT)
02900 MOVE TBITS,$TBITS(PNT)
03000 ;; #JR# BY JRL 10-17-72 A STRING ITEM IS NOT A STRING
03100 TRNE TBITS,ITEM!ITMVAR
03200 TRZ TBITS,STRING ;FORGET ABOUT STRING TYPE FOR ITEMS
03300 ;; #JR#
03400 NOSBS: TRNN TBITS,PNTVAR ;IF PNTVAR OR INDXED OR
03500 TLNE SBITS,INDXED ; REFERENCE FORMAL,
03600 TRO A,PNTROP ;INDICATE A POINTER OPERATION
03700 TLNE TBITS,REFRNC
03800 TRO A,PNTROP
03900 TRNE A,ADDR ;IF ADDR ∧ PNTROP, TURN OFF BOTH
04000 TRZE A,PNTROP ;(THE IMMEDIATENESS
04100 TRZ A,ADDR ; OF ADDR CANCELS THE INDIRECTNESS OF PNTROP
04200 TLNE TBITS,SBSCRP ;ELIMINATE FXTWO IF
04300 TRZ A,FXTWO ; ARRAY NAME
04400
04500 ;;#FP# 1-10-72 DCS (1-2)
04600 TLNE SBITS,INAC ;IN ACCUMULATOR?
04700 JRST EINAC
04800 ;;#FP#
04900 TLNE TBITS,FORMAL ;FORMAL PARAMETER (ACTUAL)?
05000 JRST EFORM ;
05100 TRNE A,PNTROP ;INDIRECTNESS DESIRED?
05200 JRST EPNT
05300 ;;#FP# 1-10-72 DCS (2-2)
05400 TLNE SBITS,PTRAC ;IN ACCUMULATOR? (WAS INAC TOO)
05500 JRST EINAC
05600 ;;#FP#
05700 TRNE A,ADDR ;SHOULD WE CONSIDER CONSTANT IMMED?
05800 JRST EVAR ;NO
05900 TLNE TBITS,CNST ;NUMERIC CONSTANT?
06000 TRNE TBITS,STRING ;
06100 JRST EVAR ; NO
00100
00200 ECONST:
00300 SKIPE OPDUN ;NEVER OPTIMIZE USER INLINE CODE
00400 JRST EVAR ; BUT REFER TO MEMORY
00500 MOVE TEMP,$VAL(PNT) ;GET VALUE
00600 TRNN A,IMMOVE ;IMMEDIATE MOVE REQUESTED?
00700 JRST OPCON1 ; NO, TEST LH0
00800 HRLI A,(<MOVE >) ;ASSUME MOVEI
00900
01000 TLC TEMP,-1 ;TEST LEFT HALF -1
01100 TLCN TEMP,-1 ;IS IT?
01200 JRST [HRL C,TEMP ;YES, SET UP
01300 HRLI A,(<HRROI>) ; INSTR
01400 JRST EAC] ;AND EMIT IT
01500 TRNE TEMP,-1 ;RIGHT HALF ZERO?
01600 JRST OPCON1 ; NO
01700 MOVSS TEMP ;YES, SWAP HALVES
01800 TLO A,4000 ; AND TURN ON MOVSI BIT
01900 OPCON1: TLNE TEMP,-1 ;LEFT HALF ZERO?
02000 JRST EVAR ;NO
02100 HRL C,TEMP
02200 LDB TEMP,[POINT 9,A,8] ;GET OP-CODE
02300 SUBI TEMP,200 ;ONLY OPCODES IN RANGE <MOVE> (200)
02400 JUMPL TEMP,EVAR ; TO <OR> (434) WILL
02500 CAILE TEMP,234 ; BE CONSIDERED
02600 JRST EVAR
02700 PUSH P,USER
02800 IDIVI TEMP,=36 ;WORD # TO TEMP, BIT # TO USER
02900 MOVE TEMP,OPBTS(TEMP);SOME BITS
03000
03100 TABCONDATA (OPCODE BITS TABLE FOR EMITER OPTIMIZER)
03200 OPBTS: 421042004000 ;BIT ON IF
03300 000000104000 ;CORRESPONDING OPCODE
03400 776000000000 ;CAN BE IMMEDIATE
03500 001040000000
03600 ENDDATA
03700
03800 LSH TEMP,(USER) ;THE RIGHT ONE
03900 POP P,USER
04000 JUMPGE TEMP,EVAR ;CAN'T OPTIMIZE, CODE WRONG
04100 CAML A,[CAM] ;THE COMPARES ARE MADE
04200 CAML A,[JUMP] ; IMMEDIATE BY TURNING OFF
04300 TLOA A,IMMED ; THE 10000 BIT, ALL OTHERS
04400 TLZ A,10000 ; BY TURNING ON THE 1000 BIT
04500 JRST EAC ;PUT OUT OPTIMIZED INSTR
04600
04700
04800
04900 EPNT: HRRE TEMP,$VAL(PNT) ;GET DISPLACEMENT IF ANY
05000 SUBI TEMP,1 ;ASSUME STRING AND ¬FXTWO
05100 TRZN A,FXTWO ;IF FXTWO OR
05200 TRNN TBITS,STRING ; ¬STRING,
05300 ADDI TEMP,1 ;REVERSE ASSUMPTION
05400 HRL C,TEMP ;GET TO DISPLACEMENT PLACE
05500 TLNE SBITS,PTRAC ;POINTER IN AC?
05600 JRST EACX ; YES
05700 TLNE C,-1 ;MAKE INDIRECT
05800 ERR <DRYROT AT EPNT>,1 ;UNLESS WE WANTED A DISPLACEMENT
05900 TRO A,INDRCT ;MAKE IT INDIRECT
06000 JRST EVAR ;GO DO FIXUPS
06100
06200 EACX: HRL D,$ACNO(PNT) ;USE AC AS INDEX
06300 TLNE TBITS,OWN ;IF ARRAY NAME COMES INTO IT,
06400 ;;# # DCS 3-25-72 Bad array address problem.
06500 TLC FF,RELOC!FFTMP1;RELOCATABLE, SHOUDN'T 0-TEST IN CODOUT
06600 ;;# #
06700 TROA A,USX ;DENOTE THAT IT SHLD BE DONE
06800 EINAC: HRL C,$ACNO(PNT) ;INAC, GET ACNO AS DISPL.
06900 JRST CHKIMM ;SEE IF ADDR IS ON
07000
07100 EFORM: TRO A,USX ;WILL NEED TO USE A STACK AS INDEX
07200 HRRZ TEMP,$ADR(PNT) ;GET DISPL FROM STACK TOP
07300 TLNE TBITS,REFRNC ;REFERENCE PARAM?
07400 JRST REFPRM ; YES
07500 NODIS <
07600
07700 VALPRM: TRNE TBITS,STRING ;STRING?
07800 JRST USERSP ; YES, USE STRING STACK
07900 >;NODIS
08000 DIS <
08100 VALPRM: TRNN TBITS,STRING ;STRING
08200 JRST REFPRM ;NO
08300 SKIPN SIMPSW
08400 TRNN SBITS,DLFLDM ;IF SIMPLE OR DL 0 THEN DO IT THE OOLD WAY
08500 JRST USERSP
08600 LDB LPSA,[LEVPOINT(SBITS)]; PICK UP LEVEL
08700 HLL D,DISTAB(LPSA) ;PICK UP REGISTER
08800 TLNN D,17
08900 ERR <DRYROT AT EFORM FOR STRING> ;BETTER NOT BE 0
09000 TRZE A,FXTWO ;IF SECONG WORD
00100 SUBI TEMP,1 ;FIX IT
00200 MOVN TEMP,TEMP
00300 HRL C,TEMP ;USE THIS DISPL
00400 JRST CHKIMM ;GO CHECK
00500 >;DIS
00600
00700 REFPRM: TLNN TBITS,SBSCRP ;IF SUBSCRIPTED AND
00800 JRST .+3 ; REFERENCE,
00900 TLNE TBITS,REFRNC ;
01000 TRZ A,PNTROP ;DO NOT GO INDIRECT.
01100 TRZE A,PNTROP ;WANT TO GET VALUE?
01200 TRO A,INDRCT ; YES, GO INDIRECT, FIND ON RP STACK
01300 DIS <
01400 LDB LPSA,[LEVPOINT(SBITS)];PICK UP DISPLY LEVEL
01500 CAIE LPSA,0 ;IF HAVE A DISPLAY
01600 JRST USEDRF ;USE IT
01700 MOVE LPSA,TPROC ;PICK UP PROC ID
01800 HRRZ LPSA,$SBITS(LPSA);PICK UP RH OF SBITS FOR PROC
01900 ADDI LPSA,1 ;WANT LEVEL OF FORMLS
02000 XOR LPSA,SBITS ;ALL THIS IS A FANCY TEST TO SEE IF THIS PROC'S
02100 TRNE LPSA,LLFLDM ;IS IT THE SAME
02200 ERR <INACCESSABLE FORMAL> ;NO
02300 SKIPN SIMPSW ;BETTER BE SIMPLE PROC
02400 ERR <DRYROT AT EPNT -- SIMPLE?> ;YOU FUCKED UP
02500 >;DIS
02600
02700
02800 USERP: HRLI D,RP ;MARK THIS STACK
02900 ADD TEMP,ADEPTH ;TOTAL ARITH STACK DEPTH
03000 JRST MAKFRM ;GO CREATE FORMAL REF INSTR
03100
03200 USERSP: HRLI D,RSP
03300 ADD TEMP,SDEPTH
03400 TRZE A,FXTWO ;SECOND WORD?
03500 SUBI TEMP,1 ;YES, DON'T GO SO FAR
03600
03700 MAKFRM: MOVNS TEMP ;NEGATIVE STACK DISPLACEMENT
03800 HRL C,TEMP ;USE THIS DISPLACEMENT
03900 ;;#KH# RHT (11-21-72) DELETED LARGE HUNKOF LEFT OVER STUFF FROM FORMFX
04000 JRST CHKIMM ;FINISH OUT
04100 DIS <
04200 USEDRF: HRL D,DISTAB(LPSA) ;PICK UP DISPLAY REGISTER
04300 TLNN D,-1 ;WAS IT LOADED
04400 ERR <DRYROT AT EFORM>,1;NO
04500 MOVN TEMP,TEMP ;NEGATE DISPL
04600 SUBI TEMP,1 ;SINCE RF IS ONE MORE AWAY
04700 HRL C,TEMP ;USE IT
04800 JRST CHKIMM ;GO FINISH UP
04900 >;DIS
05000
05100 EVAR:
05200 TLO FF,RELOC ;NOW ASSUME RELOC AGAIN
05300 DIS <
05400 TRNE A,JSFIX ;IF JUST WANT A FIXUP
05500 JRST USECR ;THEN THATS ALL YOU GET
05600 TLNE SBITS,CORTMP ;IS IT A CORE TEMP
05700 JRST [ ;YES
05800 SKIPN RECSW ;IF NOT RECURSIVE PROC THEN
05900 JRST USECR ;USE A CORE LOCN -- NO DR NEEDED
06000 MOVE LPSA,CDLEV ;USE THIS LEVEL
06100 JRST USED.1 ;NO LDB ALLOWED
06200 ]
06300 TRNE SBITS,DLFLDM ;STACK VAR?
06400 JRST USEDR ;YES
06500 >;DIS
06600 USECR:
06700 HRL C,$ADR(PNT) ;ADDR OR LAST FIXUP
06800 NOGAG <
06900 DCDFX: TRNN A,JSFIX
07000 TRNE TBITS,FORWRD!INPROG ;MUST FIXUP IF EITHER IS ON
07100 JRST DOFIX
07200 TLNN SBITS,FIXARR ;DON'T FIXUP IF FIXARR ON
07300 TRNE TBITS,PROCED!LABEL ;ELSE ONLY IF NEITHER OF THESE
07400 JRST DONTFX
07500 >;NOGAG
07600 GAG <
07700 TRNE A,JSFIX ;IF REQUESTED, ALWAYS FIX
07800 JRST DOFIX
07900 TRNN TBITS,FORWRD!INPROG ;FIX ALSO IF CODE JUMP TO NON-SET LOC
08000 JRST DONTFX
08100 >;GAG
08200 DIS <
08300 JRST DOFIX
08400 USEDR: LDB LPSA,[LEVPOINT<SBITS>] ;GET DISPLAY LEVEL
08500 USED.1: HRL D,DISTAB(LPSA) ;USE DISPLY REG
08600 TRNE TBITS,STRING ;UNLESS STRING
08700 JRST [
08800 ;#IO# RHT 7-17-72 ATTEMPT TO USE STR DR FOR A INDEXED TEMP
08900 TLNE SBITS,INDXED ;DONT IF RESULT OF ARRAY CALC
09000 JRST .+1 ;
09100 ;# #
09200 TLNN TBITS,SBSCRP ;DONT FOR ARRAYS
09300 HLL D,DISTAB(LPSA) ;CODED THIS WAY TO HANDLE USUAL CASE
09400 JRST .+1]
09500 TRNN A,USX ;BETTER NOT PLAN TO INDEX THIS
09600 TLNN D,-1 ;WAS IT LOADER
09700 ERR <DRYROT AT EVAR>,1 ;NO
09800 HRL C,$ADR(PNT) ;PICK UP DISPL
09900 TRO A,USX ;USE THE MOTHER
10000 JRST DCDFX ;GO THINK ABOUT FIXING UP
10100 >;DIS
10200
00100
00200 DOFIX: HRRZ TEMP,PCNT ;READY TO DO FIXUP CHAINING
00300 TRZE A,FXTWO ;USE SECOND FIXUP ADDR
00400 JRST [HLL C,$ADR(PNT)
00500 HRLM TEMP,$ADR(PNT) ;YES, MATTER OF FACT
00600 JRST CHKIMM]
00700 HRRM TEMP,$ADR(PNT) ;FINISH FIXUP CHAINING
00800
00900 DONTFX:
01000 TLNN SBITS,FIXARR
01100 JRST CHKIMM
01200 SUB C,[XWD 1,0] ;ASSUME STRING, NOT FXTWO
01300 TRNE TBITS,STRING ;IF NOT STRING OR IF FXTWO,
01400 TRZE A,FXTWO
01500 ADD C,[XWD 1,0] ; NULLIFY ASSUMPTION
01600 CHKIMM:
01700
01800 GAG < ;IF FXTWO STILL ON, MUST DO IT HERE -- MEANS THAT NO ONE
01900 TRZE A,FXTWO ; CAN TURN IT ON IF HE DOESN'T REALLY
02000 HLL C,$ADR(PNT) ; MEAN IT, BECAUSE HERE COMES THE 2D WORD ADDR
02100 >;GAG
02200 TRNN A,ADDR ;DO WE WANT THIS POINTER RAW?
02300 JRST EAC ; NO, FINISH UP
02400 TLO A,IMMED ;THE ONLY WAY TO DO IT HERE IS TO
02500 TRNE A,USCOND ; MAKE THE INSTR IMMEDIATE
02600 HRLI A,(<CAI>) ; (CONDITIONAL MUST BE A CAM)
02700
02800 EAC: TRNE A,INDRCT ;INDIRECT BIT WANTED?
02900 TLO A,INDIR
03000 TRNN A,NOUSAC ;AC FLD PROHIBITED?
03100 DPB D,[POINT 4,A,12] ;NO, PUT IT IN
03200 TRNE A,NORLC ;RELOCATION PROHIBITED?
03300 TLZ FF,RELOC ; YES, TAKE IT OUT
03400 TRNE A,USCOND ;CONDITION BITS NEEDED TO FINISH OPCODE
03500 DPB C,[POINT 3,A,8] ;YES, DO IT
03600 TRNE A,USX ;D(LH) TO BE USED AS INDEX FLD?
03700 TDO A,D ;YES (WIPES OUT A(RH))
03800 HLR A,C ;GET DISPL (SO DOES THIS)
03900 ;;# # DCS 3-25-72 bad array address problem
04000 MOVEI TEMP,CODOUT ;STANDARD CASE
04100 TLNN FF,FFTMP1 ;IF THIS BIT GOT TURNED OFF, CODREL SHOULD
04200 MOVEI TEMP,CODREL ; BE CALLED TO AVOID THE 0-TEST WHICH
04300 PUSHJ P,(TEMP) ; WOULD INHIBIT RELOC -- PUT OUT THE CODE
04400 ;;# #
04500 POP P,SBITS
04600 POP P,TBITS
04700 POP P,D
04800 POP P,C
04900 POP P,A
05000 POPJ P, ;RESTORE AND RETURN
05100 SUBTTL Generalized push and pop.
00100 COMMENT ⊗Qstack Routines -- BPUSH, etc.⊗
00200
00300 DSCR QSTACK ROUTINES
00400 DES These are routines to provide generalized, expandable push-
00500 down stacks (buffers? queues?) for use by algorithms which need
00600 widely varying storage, accessed in simple ways. Such structures
00700 are called QSTACKS, and are built out of Semblks as follows --
00800
00900 WORD1 -- →PREV,,→NEXT
01000 WORDS 2-11 -- up to 10 words of "stack" data
01100
01200 A stack is identified by its QPDP, or Qstack Descriptor, which is --
01300 →TOP,,→Semblk containing TOP
01400
01500 Most Qstack operations reference the address where this QPDP (there
01600 should be one QPDP which always refers to the TOP) is stored. Others
01700 may also be used in conjunction with Qstack operations
01800
01900 Qstack operations are provided to PUSH data on, POP data off (these
02000 allocate and release Semblks, if necessary, and change the TOP QPDP),
02100 access data non-destructively in forward and reverse directions, and
02200 to clear a given Qstack.
02300 ⊗
02400
02500 DSCR BPUSH
02600 CAL PUSHJ via QPUSH macro
02700 PAR LPSA → QPDP for Qstack
02800 A is data to be pushed
02900 RES QPDP is updated, A is stored in Qstack, new Semblk if necessary
03000 DES if QPDP is 0, an initial Semblk is created, QPDP constructed.
03100 SID only TEMP is changed
03200 SEE QPUSH
03300 ⊗
03400
03500 ↑BPUSH: PUSH P,A ;SAVE IT.
03600 SKIPN TEMP,(LPSA) ;THE CURRENT POINTER
03700 JRST NEWONE ;NONE YET, GUYS.
03800 HLRZ A,TEMP
03900 CAIL A,BLKLEN-1(TEMP) ;GONE OVER BLOCK BOUNDARY?
04000 JRST NOTHER ;YES
04100 PUSH1: PUSH A,(P) ;SEE !!!
04200 HRLM A,(LPSA) ;CURRENT POINTER UPDATED.
04300 POP P,A ;RESTORE
04400 POPJ P, ;DONE
04500
04600 NEWONE: PUSH P,LPSA
04700 GETBLK ;GET A NEW BLOCK.
04800 SETZM (LPSA)
04900 MOVE TEMP,LPSA ;POINTER TO NEW BLOCK.
05000 POP P,LPSA
05100 MORBLK: HRRM TEMP,(LPSA) ;UPDATE PDP POINTER.
05200 HRRZ A,TEMP
05300 JRST PUSH1 ;FINISH OUT.
05400
05500 NOTHER: PUSH P,LPSA ;SAVE IT
05600 GETBLK
05700 MOVE TEMP,LPSA ;POINTER TO NEW ONE.
05800 POP P,LPSA
05900 HRRZ A,(LPSA) ;PDP POINTER.
06000 HRLZM A,(TEMP) ;SAVE LINKS IN NEW BLOCK.
06100 HRRM TEMP,(A) ;AND IN PDP
06200 JRST MORBLK
00100
00200 DSCR BPOP
00300 CAL PUSHJ via QPOP macro
00400 PAR LPSA → QPDP
00500 RES A ← data from TOP, QPDP is updated
00600 DES Semblks are released as they are emptied
00700 SID only TEMP, A are changed
00800 ERR if there is no QPDP, or if no more data, error
00900 SEE QPOP
01000 ⊗
01100
01200 ↑BPOP: SKIPN TEMP,(LPSA) ;PDP POINTER
01300 ERR <DRYROT -- BPOP>
01400 HLRZ A,TEMP
01500 POPMOR: SUBI A,1 ;THIS IS A POP
01600 CAIGE A,(TEMP) ;GONE BELOW THIS BLOCK?
01700 JRST POPBAK ;YES ALAS
01800 HRLM A,(LPSA) ;UPDATE PDP
01900 MOVE A,1(A) ;THIS IS THE RESULT.
02000 POPJ P,
02100
02200 POPBAK: PUSH P,TEMP
02300 HLRZ TEMP,(TEMP) ;BACKWARD POINTER.
02400 PUSH P,TEMP
02500 FREBLK <-1(P)> ;DELETE THE BLOCK.
02600 POP P,TEMP
02700 POP P,(P) ;INGNORE THIS.
02800 SKIPN TEMP ;IS IT THERE?
02900 ERR <DRYROT -- BPOP>
03000 HLLZS (TEMP) ;ZERO FORWARD POINTER
03100 MOVEM TEMP,(LPSA) ;UPDATE PDP
03200 MOVEI A,BLKLEN-1(TEMP) ;NEW MAX.
03300 JRST POPMOR ;FINISH OUT.
03400
03500
03600 DSCR QTAK
03700 CAL PUSHJ, via QTAKE macro
03800 PAR B is QPDP for data word preceding one desired
03900 LPSA → QPDP for this QSTACK
04000 RES if there is more data (check via LPSA ptr):
04100 B is updated as if it were a BPUSH QPDP
04200 A receives value of TOP
04300 BTAK skips
04400
04500 if there is no more data:
04600 nothing is changed
04700 BTAK does not skip
04800 SID only A,B, TEMP changed
04900 SEE QTAKE macro
05000 ⊗
05100 ↑QTAK: CAMN B,(LPSA) ;OVERFLOW?
05200 POPJ P, ;YUP
05300 HLRZ TEMP,B
05400 CAIL TEMP,BLKLEN-1(B) ;OVERFLOW OF OTHER TYPE?
05500 JRST NEXTBL ;YES
05600 TAKMOR: MOVE A,1(TEMP)
05700 HRLI B,1(TEMP)
05800 AOS (P)
05900 POPJ P,
06000
06100 NEXTBL: HRRZ B,(B) ;GO FORWARD
06200 HRRZ TEMP,B ;NOTE THAT THE BLOCKS ARE
06300 JRST TAKMOR ;NOT DELETED !!!!!!
00100
00200 DSCR BBACK
00300 CAL PUSHJ via QBACK macro
00400 PAR B contains QPDP
00500 RES B is "popped"
00600 A receives data from TOP word
00700 if there was data left, skip-returns -- else no-skip
00800 SID only A, TEMP, B changed
00900 SEE QBACK
01000 ⊗
01100 ↑↑BBACK: HLRZ A,B ;→TOP, ACCORDING TO B'S QPDP
01200 BTMOR: SUBI A,1 ;TRY THE "POP"
01300 CAIGE A,(B) ;WAS THERE DATA LEFT HERE?
01400 JRST BTBAK ;NO, BACK UP
01500 HRLM A,B ;UPDATE B'S QPDP
01600 MOVE A,1(A) ;FETCH "TOP" ELEMENT
01700 AOS (P) ;SUCCESS UNLESS SOSED BY BTBAK
01800 QPOPJ: POPJ P, ;DONE
01900
02000 BTBAK: HLRZ B,(B) ;BACK UP
02100 JUMPE B,QPOPJ ; NO MORE DATA
02200 MOVEI A,BLKLEN-1(B) ;RESET LH PTR
02300 JRST BTMOR ;FINISH UP
02400
02500 DSCR BFLUSH
02600 CAL PUSHJ, via QFLUSH macro
02700 PAR LPSA → QPDP
02800 RES all Semblks cleared, QPDP zeroed
02900 SID A, B, TEMP changed
03000 SEE QFLUSH
03100 ⊗
03200 ↑↑BFLUSH: SKIPN A,(LPSA)
03300 POPJ P, ;NO STACK
03400 FLSHLP: HLRZ B,(A) ;GET NEXT PTR
03500 FREBLK (A) ;RELEASE TOP SEMBLK
03600 MOVE A,B
03700 JUMPN A,FLSHLP ;MAKE NEXT ONE BACK TOP ONE
03800 SETZM (LPSA) ;ALL DONE
03900 POPJ P,
04000
04100 DSCR BBEG
04200 CAL PUSHJ, via QBEGIN macro
04300 PAR B is QPDP
04400 RES B is QPDP which, when BTAKEd, returns first element in Qstack
04500 B is 0 if no Qstack exists
04600 SID only B, TEMP changed
04700 SEE QBEGIN
04800 ⊗
04900 ↑↑BBEG: SKIPN B,(LPSA) ;IS THERE A STACK?
05000 POPJ P, ; NO
05100 LOPPP: HRLS B ;MAKE INIT QPDP FOR THIS SEMBLK
05200 HLRZ TEMP,(B) ;GET BACK PTR
05300 JUMPE TEMP,CPOPJ ;WHEN HAVE REACHED FIRST SEMBLK, QUIT
05400 MOVE B,TEMP ;TRY AGAIN
05500 JRST LOPPP
00100 COMMENT ⊗PWR2⊗
00200
00300 DSCR PWR2
00400 DES Tests number in register B for being a power of 2.
00500 if so, it skip-returns (********) and C
00600 has a small integer representing the power.
00700
00800 SID AC'S: uses TEMP
00900 ⊗;
01000 ↑PWR2: JUMPLE B,CPOPJ ;ROUTINE TO TEST B FOR A POWER OF TWO.
01100 MOVN TEMP,B ;TWO'S COMPLEMENT.
01200 AND TEMP,B ;AND THE AND
01300 TLNN B,777000 ;TOO BIG ?
01400 CAME TEMP,B ;THE MAGIC TEST FOR POWER OF TWO.
01500 POPJ P, ;NO DICE.
01600 FSC B,233 ;NOW THE NORMALIZE.
01700 ASHC B,-=45 ;NOW CORRECTLY IN C. (LEFT HALF)
01800 SUB C,[XWD 201,400000]
01900 AOS (P)
02000 POPJ P,
02100
02200
02300 SUBTTL Generator Output Routines.
00100 COMMENT ⊗GBOUT Description, Loader Block Format Description⊗
00200
00300 DSCR GBOUT -- write a block of binary output
00400 DES
00500 One of the specialized output routines has produced
00600 a loader block, ready for output. These
00700 routines are:
00800
00900 CODOUT -- prepares a code block. Each call
01000 puts a word of code into a buffer and sets relocation
01100 appropriately.
01200
01300 FBOUT -- prepares a fixup block. Each call puts a fixup word into
01400 a buffer.
01500
01600 SOUT -- for outputting symbols. Each call puts a symbol
01700 name (in RADIX50) and an address into a buffer.
01800
01900 Other parts of the generators also call GBOUT for special functions
02000 (entry block, prog name block, etc). The routines
02100 call GBOUT when their buffers are full or when they
02200 wish to force out all of a given block.
02300
02400 Each block outputted by GBOUT has the same general format:
02500 WD1: BLOCK TYPE,,COUNT
02600 0≤ COUNT (WDn-WD3+1) ≤ 18
02700 WD2: relocation bits
02800 18 2-bit bytes (left-justified) corresponding
02900 to the 18 (maximum) data words in the block.
03000 The first bit of each is on if the left
03100 half is to be relocated. The second bit
03200 of each corresponds to the right half
03300 of its data word.
03400 WD3: first data word
03500 .
03600 .
03700 .
03800 WDn: last data word 2≤n≤20
03900
04000 The Binary file is opened and initialized in the command
04100 scanner (outer block of SAIL). The FF bit BINARY
04200 is on if a binary output is desired (if the file is open).
04300
04400 PAR B -- SIZE,,address of loader block
04500 SIZE is size of ENTIRE block (2 + WD1's count)
04600 It is zero if WD1's COUNT is to be believed.
04700
04800 RES The block is written if SIZE is ≥3
04900
05000 SID All ACS are preserved
05100 ⊗;
00100 COMMENT ⊗ Control Variables for Loader Block Output⊗
00200
00300 ZERODATA (REL-FILE OUTPUT VARIABLES)
00400
00500 ;CODPNT -- bp for relocation bits in BINTAB CODE block
00600 ; see GBOUT for details about relocation bits -- initted to --
00700 ↓CODPNT: POINT 2,BINTAB+1
00800
00900 ;FRSTSW -- off until first word of code goes out -- used to
01000 ; trigger output of program name block, initial code, etc.
01100 ; in CODOUT -- set on in CODOUt
01200 ↓FRSTSW: 0
01300
01400 ;FXPNT -- reloc bits bp for FXTAB FIXUP block -- see FBOUT, GBOUT
01500 ↓FXPNT: POINT 2,FXTAB+1
01600
01700 ;LSTRAD, LSTRLC, LSTWRD -- last radix50 word output, last code
01800 ; word output, last relocation bits output -- used by Boolean
01900 ; and ALLOT code, for repeating some of it
02000 ↑↑LSTRAD: 0
02100 ↑↑LSTRLC: 0
02200 ↑↑LSTWRD: 0
02300
02400 ;OUTADR -- bp set up by GBOUT for fetching words from LODBLKs
02500 ; for transfer to output buffer
02600 ↓OUTADR: 0
02700
02800 ;RAD5. -- RADIX50 creates a value corresponding to a symbol comprising
02900 ; the first 5 characters of the identifier, followed by ".", in
03000 ; addition to each value it creates. It is saved here, used sometimes.
03100 ↑↑RAD5.: 0
03200 ↑↑RAD5$: 0 ;SIMILAR, BUT WITH A $
03300 ↑↑RAD5%: 0 ;GUESS WHAT
03400 ;SMPNT -- reloc bits pb for SMTAB SYMBOLS block -- see SCOUT, GBOUT
03500 ↓SMPNT: 0
03600
03700 DATA (REL-FILE OUTPUT VARIABLES)
03800
03900 ;SALIB -- used to place main SAIL library request in LBTAB output
04000 ; loader block -- see DONES, PRGOUT
04100 ;SALIH -- re-entrant version of library
04200
04300 ↑SALIB: LIBLEN ;STRING CONSTANT, LIBLEN LONG
04400 ;;#HX# 6-24-72 DCS PARAMETERIZE LIBRARY NAMES
04500 POINT 7,[LIBLOW]
04600 REN <
04700 ↑SALIBH:LIBLEN
04800 POINT 7,[LIBHI]
04900 ;;#HX#
05000 >;REN
00100 COMMENT ⊗ Loader Output Blocks-- Entry, Program Name, Initial Stuff⊗
00200
00300 DATA (LOADER OUTPUT BLOCKS)
00400 COMMENT ⊗
00500 Here are the loader output blocks. They are formatted as described
00600 in SAILON ;;.; by Bill Weiher. The general routine GBOUT handles
00700 the actual output of these (filled) blocks to the .REL file. For
00800 several of the block types, special routines exist below (CODOUT,
00900 FBOUT, etc.) to place individual words (and their relocation) into
01000 the blocks, and to call GBOUT when a block is full
01100 ⊗
01200
01300
01400 NOGAG <
01500 COMMENT ⊗
01600 ENTTAB -- ENTRY block -- names included in SAIL ENTRY statements.
01700 This must be the first block out (due both to syntax and
01800 necessity. It allows the .REL file to be used as part
01900 of a library.
02000 ⊗
02100 LODBLK (ENTRY,4,ENTTAB,,=18)
02200
02300
02400 COMMENT ⊗
02500 PROGNAM -- PROGRAM NAME BLOCK -- output of this block is delayed until
02600 first word of code goes out, to give user longest possible time
02700 to come up with a program name. Must go out before code to name
02800 outer block symbols and labels and stuff.
02900 ⊗
03000 LODBLK (PROGNAM,6,BEGNAM,BEGCNT,1)
03100 RELOC .-1
03200 ↑↑PRGTTL: RADIX50 0,M ;DEFAULT NAME, IF NO OTHER COMES
03300
03400 COMMENT ⊗
03500 HBLK -- High Segment Block -- Denotes Re-entrant Output
03600 ⊗
03700 REN <
03800 LODBLK (HIGH,3,HBLK,HBLK2,1,,<XWD 200000,0>)
03900 RELOC .-1
04000 XWD 400000,400000 ;TWOSEG
04100 >;REN
04200
04300 >;NOGAG
04400
04500
04600 COMMENT ⊗
04700 BEGOUT -- STANDARD INITIAL CODE SEQUENCE
04800 This code is always put out, but is only executed (and fixups
04900 are only correct) for Main Programs. Sample fixed-up code is
05000 included in the comments
05100 ⊗
05200 NODIS <
05300
05400 IFN PATSW,<II←←5;>II←←4 ;NEED TO DO AOS IF PATSW
05500
05600 LODBLK (CODE,1,BEGOUT,BEGCT2,\II,,<XWD 200000,0>)
05700 RELOC .-II
05800 ↑↑BEGPC:0 ;PC ALWAYS 0 OR 400000 FOR THIS CODE
05900 SKIPA ; -- NOT STARTED IN RPG MODE
06000 SETOM ;RPGSW -- GLOBAL VARIABLE -- STARTED IN RPG MODE
06100 JSR ;SAILOR -- CALL INITIALIZER
06200 IFN PATSW,<
06300 AOS ;PAT FOR OUTER BLOCK -- SEE PROCED
06400 >;PATSW ELSE DON'T AOS
06500 >;NODIS
06600
06700 DIS <
06800
06900 LODBLK (CODE,1,BEGOUT,BEGCT2,11,,<XWD 200000,0>)
07000 RELOC .-11
07100
07200 ↑↑BEGPC:0 ;PC ALWAYS 0 OR 400000
07300 SKIPA ;NOT STARTED IN RPG
07400 SETOM ;RPGSW
07500 JSR ;SAILOR
07600 HRLOI RF,1 ;FOR FIRST LINK
07700 PUSH P,RF
07800 PUSH P, ;[PDA,,0]
07900 PUSH P,SP
08000 HRRI RF,-2(P); SET F
08100
08200 >;DIS
08300
00100 COMMENT ⊗ Code, Boolean Code, Fixups, Links⊗
00200
00300 NOGAG <
00400 COMMENT ⊗
00500 BINTAB -- MAIN CODE BLOCK
00600 All generated instructions are output via CODOUT-GBOUT
00700 to this block. See CODOUT for details
00800 ⊗
00900 LODBLK (CODE,1,BINTAB,,=18)
01000
01100
01200 COMMENT ⊗
01300 BOLOUT -- SPECIAL BOOLEAN CODE BLOCK
01400 Conditionals are output once when a condition is seen, and
01500 again (with fixups and compare op codes correct) when the
01600 entire Boolean expression has been parsed and analyzed.
01700 See BOOLEAN for details.
01800 ⊗
01900 LODBLK (CODE,1,BOLOUT,,0,,<XWD 200000,0>)
02000 ↑↑BRELC←.-1 ;TO ACCESS RELOCATION BITS
02100 ↑↑BPCNT: 0 ;PROGRAM COUNTER -- SAME AS WHEN INSTRS FIRST OUT
02200 ↑↑BWRD1: 0 ;COMPARE, SKIP, OR CONDITIONAL JUMP
02300 ↑↑BWRD2: 0 ;UNCONDITIONAL JUMP IF BWRD1 WAS A COMPARE OR SKIP
02400
02500
02600 COMMENT ⊗
02700 FXTAB -- FIXUPS
02800 Each word contains in its right half the address or stack
02900 displacement (reloc bits adj. accordingly) of a variable
03000 or instruction. The left half contains the address
03100 (relative to 0, of course) of the last instruction or data
03200 which requires this address field. This location, in turn,
03300 was compiled to refer to the next previous use of the variable
03400 or whatever... in other words, a fixup chain (terminates in 0).
03500 The LOADER uses these fixups to handle forward references to
03600 things. See FBOUT for details
03700 ⊗
03800 LODBLK (FIXUPS,10,FXTAB,,=18,-1)
03900
04000
04100 COMMENT ⊗
04200 SMTAB -- SYMBOLS
04300 All local and internal symbols, and global requests, are output
04400 through this block. See SCOUT and friends for details.
04500 ⊗
04600 LODBLK (SYMBOLS,2,SMTAB,,=18,<XWD 42104,210421>)
04700 ;(RELOCATE EVERY OTHER WORD -- GENERALLY)
04800
04900
05000 COMMENT ⊗
05100 SLNKBK -- LINK BLOCKS
05200 The string link, space link, and other links are output
05300 through this block. These links provide inter-RELfile
05400 communication (best example is link that chains all string
05500 variables together, so that STRNGC can get at them. See
05600 LNKOUT for details.
05700 ⊗
05800 LODBLK (LINK,12,SLNKBK,SDSCRP,2,,<XWD 40000,0>)
05900 RELOC .-2
06000 ↑↑LNKNM: 1 ;USUALLY STRING LINK, BY CONVENTION #1
06100 ;SPACE LINK IS #2
06200 ;SET LINK IS #3
06300 ;STRNGC ROUTINE NAMES LINK IS #4
06400 ; THESE ARE SAIL CONVENTIONS ONLY
06500 ↑↑SLNKWD: 0 ;ADDRESS OF ELEMENT OF CHAIN
06600 >;NOGAG
00100 COMMENT ⊗ Space Allocation Block
00200
00300 SBCTBL -- SPACE ALLOCATION BLOCK
00400 In this block is collected all REQUIRE specifications
00500 (except LOAD_MODULES, LIBRARIES, SOURCE_FILES) and
00600 space limits (string space, system pdl, new items, etc.)
00700 It is output as a code block. Also output is a link
00800 block tying this space block to all the others loaded
00900 together. The SAILOR (initialization) routine uses this
01000 information to provide an environment pleasing to the user.
01100 See DONES and the REQUIRE code for more details. Also GOGOL
01200 (%ALLOC) for block format explanations
01300 ⊗
01400 ↑↑SPCSIZ←←=14
01500
01600 ↑↑SPCTBL:XWD 1,SPCSIZ ;CODE BLOCK, AT LEAST SPCSIZ LONG
01700 BYTE (2) 1,0,0,0,0,1,0,0,0,0,0,0,1,1 ;PC WORD,MESLNK,TINIT,PINIT(RELOC)
01800 ↑SPCPC: 0 ;PC LOCATION
01900 0 ;LINK BLOCK PROVIDES CHAIN THROUGH THIS LOC
02000 ↑ITEMNO:0 ;MAX ITEM NUMBER DECLARED THIS COMPILATION
02100 ↑NWITM: 0 ;REQUIRE n NEW_ITEMS PUTS n HERE
02200 ↑GITEMNO:0 ;MAX (MIN?) GLOBAL ITEM NUMBER DECLARED
02300 ↑MESLNK:0 ;POINTER TO MESSAGE PROCEDURE LIST PUT HERE
02400 ↑PNAMNO:0 ;REQUIRE n NEW_PNAMES PUTS n HERE
02500 ↑VERNO: 0 ;REQUIRE n VERSION PUTS n HERE
02600 ↑SEGNAM:0 ;REQUIRE "name" SEGMENT_NAME PUTS "name" HERE IN SIXBIT
02700 ↑SEGDEV:0 ;REQUIRE "dev:file[p,pn]" SEGMENT_FILE PUTS
02800 ↑SEGFIL:0 ; dev, file, ppn IN THESE LOCS IN SIXBIT
02900 ↑SEGPPN:0 ;(LOW BIT OF DEV IS SEGMENT PROTECT BIT, NOT USED NOW)
03000 ↑TINIT: 0 ;INITIALIZATION BLOCK ADDRESS FOR DECLARED ITEM TYPES
03100 ↑PINIT: 0 ;INIT. BLOCK FOR PNAMES(DECLARED ITEMS)
03200 BLOCK 6 ;ROOM FOR MORE REQUESTS
03300 ↑SPCEND←←.-1
03400
03500
00100 COMMENT ⊗ Request Blocks -- RELfile, Libraries⊗
00200
00300 NOGAG <
00400 COMMENT ⊗
00500 PRGTAB -- RELFILE REQUEST BLOCK
00600 REQUIRE "...." LOAD_MODULE generates one of these. The LOADER
00700 loads all requested .REL files after loading all the explicit
00800 stuff. See REQUIRE code for details
00900 ⊗
01000 ;; #KS# ADD LOADVR SWITCH
01100 IFN (LOADVR-=54), <
01200 LODBLK (RELREQ,15,PRGTAB,,=18)
01300 >
01400 IFE (LOADVR-=54), <
01500 LODBLK (RELREQ,16,PRGTAB,,=18)
01600 >
01700 ;; #KS#
01800
01900 COMMENT ⊗
02000 LBTAB -- LIBRARY REQUEST BLOCK
02100 REQUIRE "...." LIBRARY generates one of these (SAIL main programs
02200 automatically request SYS:LIBSAI.REL). The LOADER searches these
02300 libraries, if necessary, after searching all the others except the
02400 automatic F4 search.
02500 ⊗
02600
02700 ;; #KS# LOADVR SWITCH
02800 IFN (LOADVR-=54), <
02900 LODBLK (LIBREQ,16,LBTAB,,=18)
03000 >
03100 IFE (LOADVR-=54), <
03200 LODBLK (LIBREQ,17,LBTAB,,=18)
03300 >
03400 ;; #KS#
03500
00100 COMMENT ⊗ Ending Code, Symbols -- END Block
00200
00300 STAROT ETC. -- ENDING STUFF.
00400 These include some constant ending code, some extra standard
00500 symbols, the starting address block, if there is one, and so on.
00600 It's too messy to use the LODBLK macro on, so here it is in
00700 all its glory--
00800 ⊗
00900 EBLEN←←. ;COLLECT LENGTH.
01000
01100 ;If this is a Main Program, a starting address block is issued
01200 ; (via the GBOUT descriptor EBDSC); else EBDSC1 is used to issue
01300 ; all but the starting address block. Starting address is always
01400 ; relative 0 (addr of the BEGOUT code--see above)
01500 ↓STAROT: XWD 7,1 ;STARTING ADDR BLOCK -- 1 DATA WORD
01600 XWD 200000,0 ;RELOCATE ADDRESS (RH)
01700 ↑STRDDR:0 ;STARTING ADDRESS ALWAYS REL 0
01800
01900 ; If Main Program, global requests must be issued to fill in
02000 ; the RPGSW and SAILOR blanks in the BEGOUT block (above)
02100 XWD 2,4 ;SYMBOL BLOCK
02200 XWD 42104,210421 ;EVERY OTHER WORD.
02300 ↑CONSYM:RADIX50 60,SAILOR;JSR REQUEST.
02400 2 ;JSR IS IN LOC 2
02500 RADIX50 60,RPGSW;FOR SETOM RPGSW BUSINESS
02600 1 ;SETOM IS IN 1
02700
02800 ; This part is always issued -- standard symbol names, end block
02900 NOSTAR: XWD 2,STRCT-NOSTAR-2;SYMBOLS
03000 XWD 40000,0;RELOCATE ONLY S.
03100 RADIX50 10,S. ;FIRST EXECUTABLE LOC IN PROG
03200 0 ;ALWAYS 0
03300 RADIX50 10,P ;SYSTEM PDP ADDR
03400 RP ;USUALLY 17
03500 RADIX50 10,SP ;STRING PDP ADDR
03600 RSP ;USUALLY 16
03700 RADIX50 10,ARERR;UUO FOR ARRAY INDEX OV/UNDERFLOW
03800 ARERR ;THE UUO OPCODE
03900 RADIX50 10,FLOAT;UUO FOR INTEGER→REAL
04000 FLOAT
04100 RADIX50 10,FIX ;UUO FOR REAL→INTEGER
04200 FIX
04300 STRCT: ;END OF EXTRA SYMBOLS
04400
04500 ; END BLOCK
04600 NOREN <
04700 XWD 5,1 ;END BLOCK.
04800 XWD 200000,0 ;RELOCATE PROGRAM BREAK WORD
04900 ↑↑PRGBRK: 0 ;PROGRAM BREAK-- FIRST NON-USED ADDR
05000 >;NOREN
05100 REN <
05200 XWD 5,2 ;TWO PROGRAM BREAKS
05300 XWD 240000,0 ;RELOCATE PROGRAM BREAK WORD
05400 ↑↑PRGBRK: 0 ;HIGH-SEG PROGRAM BREAK
05500 0 ;LOW-SEG PROGRAM BREAK
05600 >;REN
05700
05800 EBLEN←← .-EBLEN ;LENGTH OF ENTIRE OUTPUT RITUAL
05900
06000 ↑EBDSC: XWD EBLEN,STAROT ;IF MAIN PROGRAM
06100 ↑EBDSC1:XWD EBLEN+STAROT-NOSTAR,NOSTAR ;IF NOT
06200 >;NOGAG
06300 ENDDATA
00100 COMMENT ⊗ RELINI -- Loader Block Initialization⊗
00200
00300 DSCR RELINI
00400 CAL PUSHJ FROM GENINI
00500 DES SETS UP ALL REL-FILE OUTPUT STUFF BEFORE EACH COMPILATION
00600 ⊗
00700
00800 ↑↑RELINI:
00900 NOGAG <;"GOGOL" GENERATES DIRECTLY INTO CORE
01000 HLLZS BINTAB
01100 HLLZS FXTAB
01200 SETOM FXTAB+1 ;ALL RELOCATABLE
01300 HLLZS SMTAB ;CLEARS OUTPUT BUFFER COUNTS
01400 HLLZS PRGTAB ;PROGRAM AND LIBRARY REQUEST BLOCKS
01500 HLLZS LBTAB
01600 >;NOGAG
01700 MOVE A,[XWD SPCPC,SPCPC+1] ;CLEAR SPACE ALLOCATION BLOCK
01800 SETZM SPCPC
01900 BLT A,SPCEND ;SIZE ALLOCATION BLOCK.
02000 HRRI TEMP,SPCSIZ
02100 HRRM TEMP,SPCTBL
02200 POPJ P, ;RETURN TO GENINI
00100 COMMENT ⊗ GBOUT Routine⊗
00200
00300 NOGAG <
00400 ↑GBOUT:
00500 PUSH P,A ;SAVE A
00600 PUSH P,B ;SAVE ADDRESS OF BUFFER
00700 HLRZ A,B ;GET COUNT IF NONSTANDARD
00800
00900 TLO FF,IREGCT ;SET NON-STANDARD COUNT BIT
01000 HRLI B,(<POINT 36,0>) ;FOR PICKING UP WORDS
01100 MOVEM B,OUTADR ;SAVE TABLE ADDRESS
01200 JUMPN A,GBOUTA ;NOT STANDARD (FROM TABLE) COUNT
01300 HRRZ A,(B) ;GET COUNT FROM BLOCK
01400 ADDI A,2 ; +2 FOR BLOCK TYPE & RELOC
01500 TLZ FF,IREGCT ;RESET NON-STANDARD COUNT BIT
01600
01700 ; OUTPUT ROUTINE
01800
01900 GBOUTA: TLNN FF,BINARY ;IS THERE A BINARY FILE?
02000 JRST OUTDUN ;NO, DON'T WRITE
02100 CAIGE A,3 ;IS THERE ANYTHING TO WRITE?
02200 JRST OUTDUN ;NO, DON'T DO IT
02300
02400 BQN: SOSLE BINCNT ;FULL?
02500 JRST OKOUT ;NO
02600 OUTPUT BIN,0 ;EMPTY BUFFER, ON TO NEXT
02700 TSTERR BIN ;ERRORS?
02800 ERR <OUTPUT ERROR ON BINARY FILE>
02900
03000 OKOUT: ILDB B,OUTADR ;BLOCK WORD
03100 IDPB B,BINPNT
03200 SOJG A,BQN ;WRITE THEM ALL
03300
03400 OUTDUN: POP P,B ;GET BUFFER ADDR BACK
03500 TLZN FF,IREGCT ;DON-'T CLEAR IF NON-STANDARD COUNT
03600 HLLZS (B) ;CLEAR COUNT
03700 POP P,A ;RESTORE A
03800 POPJ P,
03900 >;NOGAG
00100 COMMENT ⊗ CPUSH -- SLS only⊗
00200
00300 GAG <
00400 Comment ⊗
00500 This routine places the word in A in the next available core
00600 location for the given kind of entity (determined by the pointer in
00700 LPSA on entry). This pointer accesses a 4 word block described in fits
00800 and starts below. The intent of all this is to avoid any overflow problems
00900 by using linked blocks of storage, allocating more as the need arises. ⊗
01000
01100
01200 ↑CPUSH: SKIPN TEMP,1(LPSA) ;IS IT INITED??
01300
01400 Comment ⊗ LPSA points to the second word of a four word table on
01500 entry to the procedure. This word is an AOBJN pointer which
01600 will overflow when a single block is full ⊗
01700
01800 MOVEI TEMP,WASTE-1 ;NOT INITTED, MAKE IT HARMLESS
01900 AOBJN TEMP,OKNFUL ;STILL ROOM?
02000
02100 ; NO ROOM LEFT THIS BLOCK (OR BRAND NEW LIST), GET ANOTHER
02200
02300 SAVACS <(A,B,C,D)>
02400 MOVEM TEMP,D ;SAVE POINTER (FOR JUMPS)
02500 MOVEI TEMP,7 ;END BYTE
02600 IDPB TEMP,2(LPSA) ; PUT IT AWAY
02700
02800 Comment ⊗ The last word is a byte pointer into a bit table -- 3 bits
02900 per word in each block. The bit table comes first in the block.
03000 The first word, by the way, is a pair of constants -- total size of
03100 desired blocks, and total size of bit tables for said blocks ⊗
03200
03300 HRRZ C,-1(LPSA) ;SIZE BLOCK WANTED
03400 PUSHJ P,CORGET ;GET IT
03500 ERR <CORE GONE>,1
03600 MOVE A,(LPSA) ;→PREVIOUS BLOCK
03700 HRRZM A,-2(B) ;LINK UP SO THEY CAN BE
03800 HRRZM B,(LPSA) ; DELETED LATER, IF DESIRED
03900 SKIPN 3(LPSA) ;HAS A HOME YET?
04000 MOVEM B,3(LPSA) ;NO --BUT NOW IT DOES.
04100 HRLI B,(<POINT 3,0,2>) ;NEW BYTE POINTER
04200 MOVEM B,2(LPSA)
04300 HLRZ TEMP,-1(LPSA) ;BIT TABLE SIZE
04400 ADDI B,1(TEMP) ;POINT AT SECOND DATA WORD
04500 HRLI B,(<JRST>) ;IF BLOCK CONTAINS CODE,
04600 MOVEM B,1(D) ; MUST JUMP TO NEW BLOCK, AND IF
04700 SUBI B,1 ; LAST INSTRUCTION WAS CONDITIONAL,
04800 MOVEM B,(D) ; WE NEED TWO OF THEM
04900 SUBI TEMP,-2(C) ;DATA COUNT - 1 (TWO JUMPS)
05000 HRL TEMP,B ;REVERSED IOWD
05100 MOVSS TEMP ; (AOBJN'D ONCE)
05200 RESTACS <(D,C,B,A)>
05300
05400 OKNFUL: MOVEM TEMP,1(LPSA) ;UPDATED AOBJN POINTER
05500 MOVEM A,(TEMP) ;STORE THE DATA
05600 DPB B,2(LPSA) ;PRESENT BITS.
05700 HRLOS B
05800 IDPB B,2(LPSA) ;AND A BYTE 7 TO END IT.
05900 HLRZS B
06000 POPJ P, ;GO AWAY
06100
06200 >;GAG
00100 COMMENT ⊗ CODOUT Routine -- Output Code or Data⊗
00200
00300 DSCR CODOUT -- WRITE DATA (ALSO CODREL)
00400
00500 PAR WORD IN "A"
00600 relocatable if RELOC in in "FF"
00700 (if rh of A is zero, then never RELOC. If you want to
00800 TO BYPASS THIS TEST, CALL "CODREL").
00900
01000 RES Writes word, increments program counter (PCNT)
01100
01200 SID Uses A,B,C -- Saves all
01300 ⊗;
01400
01500 ↑CODOUT:
01600 PUSH P,A
01700 PUSH P,B
01800
01900 SKIPE FRSTSW ;HAVE WE DONE THIS BEFORE
02000 JRST COD1 ; YES, DON'T DO AGAIN
02100 SETOM FRSTSW
02200 PUSH P,LPSA ;AND SOME OTHERS
02300 MOVEI LPSA,IPROC ;GET PROGRAM NAME.
02400 PUSHJ P,RAD50 ;IN RADIX50
02500 TLZ A,740000 ;RADIX50 0,NAME
02600 MOVEM A,PRGTTL
02700 MOVE B,BEGCNT
02800 PUSHJ P,GBOUT ;WRITE NAME BLOCK
02900 REN <
03000 MOVEI A,0
03100 SKIPN HISW ;TWO-SEGMENT PROGRAM?
03200 JRST JUST1 ;NO
03300 MOVE B,HBLK2 ;YES, WRITE HISEG (TYPE 3) BLOCK
03400 PUSHJ P,GBOUT
03500 MOVEI A,400000 ;BEGINNING PC
03600 JUST1:
03700 MOVEM A,BEGPC ;IN WHICH SEGMENT
03800 >;REN
03900 MOVE B,BEGCT2 ;CALL TO INIT & LINKAGE
04000 PUSHJ P,GBOUT
04100 COD2: POP P,LPSA
04200 MOVE A,-1(P) ;RESTORE A.
04300
04400 COD1: TRNN A,-1 ;ZERO ADDRESS?
04500 TLZ FF,RELOC ;YES, NO RELOC
04600 JRST CDRL1
04700 ↑CODREL:
04800 PUSH P,A ;ENTER HERE TO BYPASS ZERO TEST
04900 PUSH P,B
05000 CDRL1:
05100 HRRZ B,BINTAB ;GET COUNT
05200 JUMPN B,BAQ ;FIRST WORD OF BLOCK?
05300
05400 AOS BINTAB ;YES, SET UP BLOCK
05500 MOVE B,PCNT ;SET LOCATION WORD
05600 MOVEM B,BINTAB+2 ;INTO 3D WORD OF BLOCK
05700 SETZM BINTAB+1 ;CLEAR RELOCATION BITS
05800 MOVE B,[POINT 2,BINTAB+1] ;BYTE POINTER FOR RELOC BITS
05900 MOVEM B,CODPNT ;TO RIGHT PLACE
06000 MOVEI B,1 ;RELOCATE THE LOC COUNTER WORD
06100 IDPB B,CODPNT
06200
06300 BAQ: AOS B,BINTAB ;INCREMENT COUNT
06400 HRRZS B ;AND MOVE TO B
06500 MOVEM A,BINTAB+1(B) ;DEPOSIT WORD
06600 MOVEM A,LSTWRD ;SAVE LAST WORD OUTPUT
06700 LDB A,[POINT 1,FF,RLCPOS] ;RELOC?
06800 DIS <
06900 SKIPE LHRELC ;RELOC LEFT HALF?
07000 ADDI A,2 ;SAY SO
07100 >;DIS
07200 MOVEM A,LSTRLC ;AND LAST RELOCATION BIT.
07300 IDPB A,CODPNT ;SET RELOC BITS
07400
07500 AOS PCNT ;INCREMENT COUNT
07600
07700 CAIGE B,22 ;FULL?
07800 JRST CDRET ;NO, RETURN
07900
08000 MOVEI B,BINTAB ;INDICATE STANDARD COUNT AND WHICH TABLE
08100 PUSHJ P,GBOUT ;WRITE BLOCK
08200 ; JRST CDRET
08300
08400 CDRET: POP P,B
08500 POP P,A
08600 POPJ P,
08700
08800 DIS <
08900 ↑CODLRL: ;RELOCATE LEFT HALF -- FF SAYS ABOUT RIGHT HALF
09000 TLNE A,-1 ;NEVER RELOCATE 0
09100 SETOM LHRELC ;SET FLAG
09200 PUSHJ P,CODOUT
09300 SETZM LHRELC
09400 POPJ P,
09500
09600 ZERODATA( DISPLAY STUFF)
09700 LHRELC: 0
09800 ENDDATA
09900
10000 >;DIS
10100
00100
00200 DSCR FRBT
00300 DES Force out current binary (BINTAB) code block,
00400 even if it's not full yet. This is done whenever
00500 symbols or fixups which might refer to this code
00600 are put out, so that there is something to fixup
00700 or refer to symbolically. It is also called from DONES.
00800 SID Saves all ACS
00900 ⊗
01000
01100 NOGAG < ;DON'T NEED FOR "GOGOL"
01200 ↑FRBT: PUSH P,B
01300 MOVEI B,BINTAB
01400 PUSHJ P,GBOUT ;CLEAR BINARY BUFFER
01500 POP P,B
01600 POPJ P,
01700 >;NOGAG
01800
01900 GAG < ;VARIABLE AND STRING ADDRESS ASSIGNERS
02000 ↑VAROUT: PUSH P,A ;SAVE OVER TDZA
02100 PUSH P,LPSA ;SAVE THIS TOO, PLEASE
02200 MOVEI A,0 ;ZERO INITIAL VALUE
02300 MOVEI LPSA,VARSTK ;PUT IT HERE
02400 PUSHJ P,CPUSH ;DO IT
02500 JRST RR2 ;REMOVE 2, RETURN
02600
02700 ↑STVOUT: SAVACS <(A,LPSA,B)>
02800 SETZB A,B ;NULL STRING, ZERO BITS
02900 MOVEI LPSA,STRSTK
03000 PUSHJ P,CPUSH
03100 PUSHJ P,CPUSH ;TWO GAG WORDS
03200 RR1: POP P,B
03300 RR2: RESTACS <(LPSA,A)>
03400 POPJ P,
03500
03600
03700 ; MAKE SURE n CODE WORDS WILL BE IN SAME BLOCK
03800
03900 ↑TWOOUT:
04000 HLRE TEMP,CODSTK+1 ;GET REMAINING COUNT
04100 ADDI TEMP,-1(LPSA) ;LPSA HAS DESIRED # OF CONTIGUOUS WORDS
04200 JUMPL TEMP,CCPOPJ ;THEY WILL ALL FIT
04300 PUSH P,A
04400 MOVE A,[JFCL] ;PUT OUT ENOUGH NO-OPS
04500 NOTH: PUSHJ P,CODOUT
04600 AOBJN TEMP,NOTH ;TEMP UPDATED BY CODOUT
04700 POP P,A
04800 CCPOPJ: POPJ P,
04900
05000 >;GAG
00100 COMMENT ⊗ FBOUT, etc. -- Output Fixups⊗
00200
00300 DSCR FBOUT,FIXOUT,FBOSWP
00400 DES Put word of fixup information into output file.
00500 PAR B contains fixup specification:
00600 lh -- PCNT of actual location of entity
00700 rh -- PCNT of last word in fixup chain.
00800 FBOSWP takes the above B value, swapped.
00900 RES This word is written into the FXTAB fixup Loader
01000 block via GBOUT (when there are enough).
01100 FBOUT always assumes both halves reloatable
01200 FIXOUT always assumes the actual (lh) address is not
01300 relocatable
01400 FBOSWP is included for convenience
01500 SID Saves all ACs
01600 ⊗;
01700
01800 DIS <
01900 ↑FXOSW2: MOVSS B
02000 PUSHJ P,FIXOUT
02100 MOVSS B
02200 POPJ P,
02300 ↑FBOSW2: MOVSS B
02400 PUSHJ P,FBOUT
02500 MOVSS B
02600 POPJ P,
02700 >;DIS
02800
02900 NOGAG <
03000 ↑FBOSWP: MOVSS B
03100 ↑FBOUT: TLNN B,-1 ;IS LEFT HALF ZERO?
03200 ERR <DRYROT -- FBOUT>,1
03300 TLOA FF,FFTEMP ;USE RELOCATION IN FIXUP SIDE
03400 ↑FIXOUT:
03500 TLZ FF,FFTEMP ;DO NOT RELOCATE FIXUP PART
03600 PUSH P,B
03700 PUSH P,A ;SAVE A
03800 HRRZ A,FXTAB
03900 JUMPN A,FAQ ;FIRST WORD OF BLOCK?
04000 MOVE A,[POINT 2,FXTAB+1] ;YES, RESET RELOCATION BIT POINTER
04100 MOVEM A,FXPNT ; (SEE CODOUT FOR SIMILARITIES)
04200 FAQ:
04300 AOS A,FXTAB ;INCREMENT AND FETCH COUNT
04400 HRRZS A
04500 MOVEM B,FXTAB+1(A) ;DEPOSIT WORD
04600 MOVEI B,3 ;ASSUME BOTH HALVES RELOC
04700 TLNN FF,FFTEMP ;TEST ASSUMPTION
04800 MOVEI B,2 ; WRONG
04900 IDPB B,FXPNT ;INSERT RELOCATION BITS
05000
05100 CAIGE A,22 ;FULL?
05200 JRST FXRET ;NO, RETURN
05300
05400 PUSHJ P,FRBT ;FORCE OUT ANY BINARY
05500 ;(BECAUSE FIXUPS HAVE TO COME AFTER)
05600
05700 MOVEI B,FXTAB
05800 PUSHJ P,GBOUT ;WRITE BLOCK
05900
06000 FXRET: POP P,A
06100 POP P,B
06200 POPJ P,
06300
06400 >;NOGAG
06500 GAG < ;CHAIN FIXUP ROUTINE FOR "GOGOL"
06600 ↑FBOUT: ;IN "GOGOL", CALLS TO THIS ARE TO CHAIN
06700 ↑CHAIN: PUSH P,B ;SAME FORMAT AS FBOUT
06800 MOVSS B ;PUT IN REASONABLE FORMAT
06900 CH1: HRRZ TEMP,(B) ;GET CHAIN ADDRESS FROM TARGET WORD
07000 HLRM B,(B) ;PUT REAL VALUE IN TARGET
07100 HRRM TEMP,B ;NEW TARGET IF ANY
07200 JUMPN TEMP,CH1 ;CONTINUE IF NOT DONE (STERLING!)
07300 POP P,B
07400 POPJ P,
07500 >;GAG
07600
00100 COMMENT ⊗ SCOUT, etc. -- Output Symbols⊗
00200
00300 DSCR SOUT,SCOUT,SHOUT,SCOUT0
00400 DES Output symbols in RADIX50 -- many ways exist for
00500 obtaining symbols for output, thus the proliferation.
00600
00700 PAR
00800 SOUT: LPSA -- Semantics ptr. $PNAME and $ADR are used to
00900 obtain the symbol and address.
01000 SHOUT: LPSA -- descriptor of the form:
01100 bits 0-5 DDT symbol type
01200 6-17 #characters
01300 18-35 address of string in ASCII (assumed justified)
01400 B -- address for symbol
01500 SCOUT: A -- RADIX50 for symbol
01600 B -- address for symbol
01700 SCOUT0: SAME AS SCOUT, BUT MAKES SYMBOL NON-RELOCATABLE.
01800
01900 SID A, TEMP, may be different on exit
02000 ⊗;
02100
02200 ↑SHOUT: PUSHJ P,RAD52
02300 JRST SCOUT ;MAKE RADIX50 FROM DESCRIPTOR
02400
02500 ↑SCOUT0: PUSH P,B ;NON-RELOCATED SYMBOL
02600 MOVEI TEMP,0
02700 JRST SASS
02800
02900
03000 ↑SOUT: PUSHJ P,RAD50 ;GET RADIX50 FOR SYMBOL
03100 PUSH P,B ;SAVE IT
03200 SKIPA B,$ADR(LPSA) ;GET ADDRESS FOR SYMBOL
03300 ↑SCOUT: PUSH P,B ;SAVE
03400 MOVEI TEMP,1 ;RELOCATION BIT.
03500 SASS: PUSH P,C
03600 NOGAG < ;INSERT DIRECTLY TO INCORE TABLE IF "GOGOL"
03700 HRRZ C,SMTAB
03800 JUMPN C,SAQ
03900 MOVE C,[POINT 4,SMTAB+1]
04000 MOVEM C,SMPNT
04100 >;NOGAG
04200 SAQ:
04300 CAMN A,LSTRAD ;RADIX50 FOR LAST BLOCK NAME.
04400 JRST SYMRET ;DO NOT PUT IT OUT.
04500 NOGAG <
04600 AOS C,SMTAB ;BINARY DOES NOT HAVE TO BE
04700 HRRZS B ;FORCED OUT
04800 MOVEM A,SMTAB+1(C)
04900 MOVEM B,SMTAB+2(C)
05000 AOS C,SMTAB
05100 HRRZS C
05200 LDB B,[POINT 4,A,3] ;DON'T RELOCATE BLOCK LEVELS
05300 CAIN B,3 ;BLOCK TYPE 14
05400 MOVEI TEMP,0
05500 IDPB TEMP,SMPNT
05600 CAIGE C,22
05700 JRST SYMRET
05800
05900 PUSHJ P,FRBT ;MAKE BINARY GO FIRST
06000 MOVEI B,SMTAB
06100 PUSHJ P,GBOUT
06200
06300 >;NOGAG
06400 GAG <
06500 PUSHJ P,INSYM ;INSERT INTO GAG SYMBOL TABLE
06600 >;GAG
06700 SYMRET: POP P,C
06800 POP P,B
06900 POPJ P,
00100
00200 GAG <
00300 ↑INSYM: MOVE TEMP,JOBSYM ;ADD SOME SYMBOL
00400 CAMN TEMP,SYMJOB ;ALL DONE?
00500 JRST [ERR <NO MORE SYMBOL ROOM>,1
00600 POPJ P,]
00700 SUB TEMP,[XWD 2,2] ;MAKE ROOM
00800 MOVEM TEMP,JOBSYM
00900 MOVEM A,(TEMP) ;NAME
01000 MOVEM B,1(TEMP) ;VALUE
01100 POPJ P,
01200
01300
01400 ;FIND A SPECIFIED SYMBOL IN DDT (RAID) SYMBOL TABLE
01500
01600 ↑LUKSYM:
01700 BEGIN LUKSYM
01800 VARBL <(SVPGPT,SAVPGN,SVBLPT,SAVBLN)>
01900
02000 EXCH A,-1(P) ;SYMBOL NAME
02100 EXCH B,-2(P) ;BLOCK NAME
02200 EXCH C,-3(P) ;PROGRAM NAME
02300 PUSH P,LPSA
02400 JUMPE C,LUKALL ;IF 0 PROGRAM NAME, LOOK EVERYWHERE.
02500 MOVE LPSA,SVPGPT ;IN CASE SAME AS LAST
02600 CAMN C,SAVPGN ;SAME PROGRAM NAME?
02700 JRST RITEPG ; YES
02800 MOVE LPSA,JOBSYM ;FIND END OF SYMBOLS
02900 HLRE TEMP,LPSA ;-LENGTH
03000 LOOP: SUB LPSA,TEMP ;RH IS → END OF SYMBOLS + 1
03100
03200 CAMN C,-2(LPSA) ;RIGHT PROGRAM?
03300 JRST RITEPG ; YES
03400 HLRE TEMP,-1(LPSA) ;LENGTH TO NEXT
03500 MOVNS TEMP
03600 JUMPN TEMP,LOOP ;IF MORE, GO ON
03700 ERR <CAN'T FIND PROGRAM -- LUKSYM>,1
03800
03900 RITEPG: MOVEM C,SAVPGN ;MAKE NEXT TIME QUICKER MAYBE
04000 MOVEM LPSA,SVPGPT
04100 HRRZI LPSA,-4(LPSA) ;CLEAR LH, BACK UP TO START BLOCK SRCH
04200 CAMN B,SAVBLN ;HAVE IT ALREADY?
04300 MOVE LPSA,SVBLPT ; YES, MOVE FASTER
04400 HRRZ C,JOBSYM ;FOR REFERENCE
04500 SUBI C,(LPSA) ;-DISTANCE TO THIS BLOCK NAME (IF ANY)
04600 ASH C,-1 ;#SYMBOLS
04700
04800 LOOP1: CAMN B,(LPSA) ;FOUND RIGHT BLOCK?
04900 JRST RITEBL ; YES
05000 SUBI LPSA,2
05100 AOJLE C,LOOP1 ;GO UNTIL CAN GO NO FURTHER
05200 ERR <CAN'T FIND BLOCK -- LUKSYM>,1
05300
05400 RITEBL: MOVEM B,SAVBLN ;SPEED UP NEXT TIME
05500 MOVEM LPSA,SVBLPT
05600 HRRZ B,1(LPSA) ;BLOCK LEVEL OF RIGHT BLOCK
05700
05800 LOOP3: SUBI LPSA,2 ;LOOK AT NEXT SYMBOL
05900 LDB TEMP,[POINT 4,(LPSA),3] ;BLOCK TYPE
06000 JUMPE TEMP,NOFND ;NEW PROGRAM, IT'S ALL OVER
06100 CAIN TEMP,14 ;BLOCK NAME?
06200 JRST [CAML B,1(LPSA) ;YES, IS IT CONTAINED IN THE RIGHT ONE?
06300 JRST NOFND ;YES, LOSE
06400 JRST LOOP3] ;NO, IGNORE IT
06500 CAME A,(LPSA) ;SAME SYMBOL?
06600 AOJL C,LOOP3 ;NO
06700 GOTIT: AOS -1(P) ;SUCCESS
06800 HRL C,1(LPSA) ;RESULT (ADDRESS FROM TABLE)
06900 NOFND: POP P,LPSA ;SAVED WORD
07000 POP P,TEMP ;RETURN ADDR
07100 POP P,A ;OLD A
07200 POP P,B ;OLD B
07300 HRR C,(P) ;RH ONLY
07400 SUB P,X11 ;OLD C
07500 JRST (TEMP)
07600
07700 LUKALL: MOVE LPSA,JOBSYM
07800 CAMN A,(LPSA) ;SYMBOL MATCH?
07900 JRST GOTIT ;YES
08000 ADD LPSA,X22
08100 JUMPL LPSA,.-3
08200 JRST NOFND ;NO ANSWER.
08300
08400 BEND LUKSYM
08500
08600 >;GAG
00100 COMMENT ⊗ LNKOUT -- Output Linkage Block⊗
00200
00300 DSCR LNKOUT --
00400 DES Put out a (type 12) Link block via GBOUT. These blocks
00500 allow chains of addresses to be created through separate
00600 .REL files. STRINGC uses LINK 1 to find all its strings.
00700 Other uses are for SETS, STRINGC routine names, and the
00800 space allocation block.
00900 PAR B -- link number
01000 PCNT -- decremented by one; that is address for LINK rqst.
01100 ⊗
01200
01300 NOGAG < ;NO NEED IN "GOGOL"
01400 ↑LNKOUT: MOVEM B,LNKNM ;SAVE LINK NUMBER
01500 PUSHJ P,FRBT ;NOTE DOES NOT SAVE ACS
01600 HRRZ TEMP,PCNT
01700 SUBI TEMP,1 ;LAST WORD OUTPUT WILL HOLD LINK
01800 HRRZM TEMP,SLNKWD ;PLACE IN ADDR WORD OF LINK BLOCK TEMPLATE
01900 MOVE B,SDSCRP ;DESCRIPTOR OF LINK BLOCK [COUNT,ADDR OF TEMPLATE]
02000 PUSHJ P,GBOUT
02100 POPJ P, ;RETURN AFTER WRITING BLOCK
02200 >;NOGAG
00100 COMMENT ⊗ PRGOUT, FILSCN -- Output Request Blocks, Scan for Source_file Rqst⊗
00200
00300 DSCR FILSCN -- CONVERT ASCII FILE-STRING TO SIXBIT
00400 PAR PNAME, PNAME+1 describe a String representing the file
00500 name.
00600 RES A, C, D return DEVICE, FILENAME, and PPN in SIXBIT
00700 DES Converts String to SIXBIT via FILNAM routine (approp-
00800 riately informed) in Command Scanner (SAIL). Extension
00900 not returned, because there's currenlty no need.
01000 SID Nothing much saved
01100 SEE FILNAM, PRGOUT, RQSET, SRCSWT
01200 ⊗
01300 ↑↑FILSCN: SETOM TYICORE ;TYI IN COMND WILL GET CHARS FRM STRNG
01400 PUSH P,DEVICE ;SAVE FILE DATA
01500 PUSH P,EXTEN
01600 PUSH P,SAVTYI
01700 PUSH P,EOL
01800 SETZM SAVTYI ;NO SCAN-AHEAD
01900 MOVSI TEMP,(<SIXBIT /DSK/>) ;DEFAULT DEVICE
02000 MOVEM TEMP,DEVICE
02100 PUSHJ P,FILNAM ;GET SIXBITS IN NAME, EXTEN, ETC.
02200 MOVE A,DEVICE ;LOAD RESULTS
02300 MOVE C,NAME
02400 MOVE D,PPN
02500 POP P,EOL
02600 POP P,SAVTYI
02700 POP P,EXTEN
02800 POP P,DEVICE ;RESTORE OLD VALUES
02900 POPJ P,
03000
03100 DSCR PRGOUT -- OUTPUT PROGRAM AND LIBRARY REQUEST BLOCKS
03200 DES Output (via GBOUT) Program and Libraray REQUEST BLOCKS.
03300 PAR B → PRGTAB or LBTAB (program or library request)
03400 PNAME, PNAME+1 as in FILSCN
03500 Defaults as in FILSCN; DEVICE, FILE and PPN will be passed
03600 to the loader.
03700 RES FILSCN is called to make SIXBIT representations of DEVICE,
03800 FILE, and PPN; these are placed in the output block.
03900 SID Saves the world
04000 ⊗;
04100
04200 ↑↑PRGOUT:
04300 MOVE USER,GOGTAB ;SAVE ACS IN USER TABLE AREA
04400 HRRZI TEMP,RACS(USER)
04500 BLT TEMP,SBITS2+RACS(USER) ;FILNAME USES MANY ACS
04600 PUSHJ P,FILSCN ;GET SIXBITS IN A,C,D
04700 MOVE B,RACS+2(USER) ;GET TABLE ADDRESS BACK
04800 MOVEI TEMP,3 ;PREPARE TO COUNT UP BLOCK COUNT
04900 ADDB TEMP,(B)
05000 ADDI TEMP,(B) ;→AREAS TO BE FILLED
05100 MOVEM C,-1(TEMP) ;STORE NAME
05200 MOVEM D,00(TEMP) ;STORE PPN
05300 MOVEM A,01(TEMP) ;STORE DEVICE
05400 HRRZS TEMP
05500 NOWOM <
05600 CAIL TEMP,22(B) ;BLOCK FULL?
05700 PUSHJ P,GBOUT ;YES, PUT IT OUT
05800 >;NOWOM
05900 HRLZI TEMP,RACS(USER)
06000 BLT TEMP,SBITS2
06100 POPJ P, ;TRA 0,4?
06200 SUBTTL Generator Miscellaneous.
00100 COMMENT ⊗ RAD50, RAD52 -- Radix-50 Functions for Scout Routines⊗
00200
00300 DSCR RAD50,RAD52 -- create a RADIX50 symbol
00400 PAR RAD50 -- LPSA → block head -- string is in $PNAME, etc.
00500 RAD52 -- LPSA(lh) is count, LPSA (rh) is address of string,
00600 assumed aligned.
00700 RES RADIX50 for symbol in A
00800 SID Results in A, all other ACS saved (except TEMP)
00900 ⊗;
01000
01100 ↑RAD50:
01200 EXCH SP,STPSAV
01300 MOVSS POVTAB+6 ;ENABLE FOR STRING PDL OV
01400 PUSH SP,$PNAME(LPSA) ;COLLECT POINTERS IN COMMON SPOT
01500 PUSH SP,$PNAME+1(LPSA)
01600 HRRZS -1(SP) ;CLEAR STRNO, SAVE COUNT
01700 MOVE A,$TBITS(LPSA) ;CONTROLS MODE BITS IN RAD50 SYMBOL
01800 MOVEI TEMP,10/4 ;ASSUME LOCAL
01900 TLNE A,INTRNL ;INTERNAL IS TYPE 4
02000 MOVEI TEMP,4/4
02100 TLNE A,EXTRNL
02200 MOVEI TEMP,60/4 ;EXTERNAL IS TYPE 60
02300 MOVEI A,0 ;INITIALIZE A
02400 JRST RAD5
02500
02600
02700 ↑RAD52:
02800 LDB TEMP,[POINT 12,LPSA,17] ;COUNT
02900 EXCH SP,STPSAV
03000 MOVSS POVTAB+6 ;ENABLE FOR STRING PDLOV
03100 PUSH SP,TEMP
03200 PUSH SP,LPSA ;MAKE IT LOOK LIKE STRING
03300 HRRI TEMP,(<POINT 7,0>) ; DESCRIPTOR
03400 HRLM TEMP,(SP)
03500 MOVEI A,0
03600 LDB TEMP,[POINT 4,LPSA,3]
03700
03800 RAD5: PUSH P,TEMP
03900 PUSH P,B ;SAVE IT
04000 MOVEI TEMP,6
04100
04200 R50LUP: SOSGE -1(SP) ;QUIT IF NO MORE STRING
04300 JRST R5OUT
04400 ILDB B,(SP) ;CHARACTER
04500 CAIN B," " ;IGNORE BLANKS ABSOLUTELY!
04600 JRST R50LUP ; THIS RUNS ALL THE CHARACTERS TOGETHER
04700 CAIL B,"a"
04800 CAILE B,"z"
04900 JRST .+2
05000 SUBI B,40 ;CONVERT TO UPPER CASE
05100 CAIE B,"_" ;THESE CHARS HAVE TO BE CREATED INDIVIDUALLY
05200 CAIN B,"."
05300 MOVEI B,66+45 ;RAD50 CHAR FOR "." + 66 TO BE SUBTRACTED
05400 ;;#GQ# DCS 2-8-72 (1-1) ! ≡ _
05500 CAIN B,"!" ;! ≡ _
05600 MOVEI B,66+45 ;"."
05700 ;;#GQ# (1)
05800 CAIN B,"$"
05900 MOVEI B,66+46
06000 CAIN B,"%"
06100 MOVEI B,66+47
06200 SUBI B,66 ;OK IF A LETTER
06300 CAIG B,12 ;<12 IF A NUMBER
06400 ADDI B,7 ; THIS MAKES IT RIGHT
06500 IMULI A,50 ;THAT'S THE NUMBER ALL RIGHT
06600 ADD A,B ;COLLECT RADIX50
06700 SOJN TEMP,R50LUP ;QUIT AT 6
06800
06900 R5OUT: MOVEM A,RAD5. ;NOW CREATE SAME SYMBOL WITH
07000 JUMPLE TEMP,MORFIV ;MORE THAN FIVE CHARS?
07100 IMULI A,50 ;MAKE IT "SYMB".
07200 JRST LESSIX
07300 MORFIV: SUB A,B ;"." IN PLACE OF THE LAST
07400 LESSIX:
07500 ADDI A,46 ;$
07600 MOVEM A,RAD5$
07700 ADDI A,1 ;%
07800 MOVEM A,RAD5% ;
07900 SUBI A,2 ;"."
08000 EXCH A,RAD5. ; AND STORE IT IN RAD5. FOR STRINGS
08100 SUB SP,X22
08200 EXCH SP,STPSAV ;RESTORE REGS
08300 MOVSS POVTAB+6 ;RE-ENABLE FOR PARSE PDLOV
08400 POP P,B
08500 POP P,TEMP
08600 DPB TEMP,[POINT 4,A,3] ;TYPE BITS
08700 DPB TEMP,[POINT 4,RAD5.,3]
08800 POPJ P,
08900
09000 BEND TOTAL
09100 IFN FTDEBUG, <↑INNA←INNA>
09200